;;; -*-lisp-*-
;;;
;;; Code generation protocol
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensble Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; SOD is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with SOD; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(cl:in-package #:sod)

;;;--------------------------------------------------------------------------
;;; Temporary names.

;; Protocol.

(export 'format-temporary-name)
(defgeneric format-temporary-name (var stream)
  (:documentation
   "Write the name of a temporary variable VAR to STREAM."))

(export 'var-in-use-p)
(defgeneric var-in-use-p (var)
  (:documentation
   "Answer whether VAR is currently being used.  See WITH-TEMPORARY-VAR.")
  (:method (var)
    "Non-temporary variables are always in use."
    t))
(defgeneric (setf var-in-use-p) (value var)
  (:documentation
   "Record whether VAR is currently being used.  See WITH-TEMPORARY-VAR."))

;; Root class.

(export 'temporary-name)
(defclass temporary-name ()
  ((tag :initarg :tag :reader temp-tag))
  (:documentation
   "Base class for temporary variable and argument names."))

;; Important variables.

(defparameter *temporary-index* 0
  "Index for temporary name generation.

   This is automatically reset to zero before the output functions are
   invoked to write a file.  This way, we can ensure that the same output
   file is always produced from the same input."
  ;; FIXME: this is currently a lie.  Need some protocol to ensure that this
  ;; happens.
)

;; Important temporary names.

(export '(*sod-ap* *sod-master-ap*))
(defparameter *sod-ap*
  (make-instance 'temporary-name :tag "sod__ap"))
(defparameter *sod-master-ap*
  (make-instance 'temporary-name :tag "sod__master_ap"))

;;;--------------------------------------------------------------------------
;;; Instructions.

;; Classes.

(export 'inst)
(defclass inst () ()
  (:documentation
   "A base class for instructions.

   An `instruction' is anything which might be useful to string into a code
   generator.  Both statements and expressions map can be represented by
   trees of instructions.  The DEFINST macro is a convenient way of defining
   new instructions.

   The only important protocol for instructions is output, which is achieved
   by calling PRINT-OBJECT with *PRINT-ESCAPE* nil.

   This doesn't really do very much, but it acts as a handy marker for
   instruction subclasses."))

(export 'inst-metric)
(defgeneric inst-metric (inst)
  (:documentation
   "Returns a `metric' describing how complicated INST is.

   The default metric of an inst node is simply 1; INST subclasses generated
   by DEFINST (q.v.) have an automatically generated method which returns one
   plus the sum of the metrics of the node's children.

   This isn't intended to be a particularly rigorous definition.  Its purpose
   is to allow code generators to make decisions about inlining or calling
   code fairly simply.")
  (:method (inst) 1))

;; Instruction definition.

(export 'definst)
(defmacro definst (code (streamvar) args &body body)
  "Define an instruction type and describe how to output it.

   An INST can represent any structured piece of output syntax: a statement,
   expression or declaration, for example.  This macro defines the following
   things:

     * A class CODE-INST to represent the instruction.

     * Instance slots named after the ARGS, with matching keyword initargs,
       and INST-ARG readers.

     * A constructor MAKE-CODE-INST which accepts the ARGS (in order, not
       with keywords) as arguments and returns a fresh instance.

     * A print method, which prints a diagnostic dump if *PRINT-ESCAPE* is
       set, or invokes the BODY (with STREAMVAR bound to the output stream)
       otherwise.  The BODY is expected to produce target code at this
       point."

  (let ((inst-var (gensym "INST"))
	(class-name (symbolicate code '-inst))
	(keys (mapcar (lambda (arg) (intern (symbol-name arg) :keyword))
		      args)))
    `(progn
       (defclass ,class-name (inst)
	 ,(mapcar (lambda (arg key)
		    `(,arg :initarg ,key :reader ,(symbolicate 'inst- arg)))
		  args keys))
       (defun ,(symbolicate 'make- code '-inst) (,@args)
	 (make-instance ',class-name ,@(mappend #'list keys args)))
       (defmethod inst-metric ((,inst-var ,class-name))
	 (with-slots (,@args) ,inst-var
	   (+ 1 ,@(mapcar (lambda (arg) `(inst-metric ,arg)) args))))
       (defmethod print-object ((,inst-var ,class-name) ,streamvar)
	 (with-slots (,@args) ,inst-var
	   (if *print-escape*
	       (print-unreadable-object (,inst-var ,streamvar :type t)
		 (format stream "~@<~@{~S ~@_~S~^ ~_~}~:>"
			 ,@(mappend #'list keys args)))
	       (progn ,@body)))))))

;; Important instruction classes.

(export '(block-inst make-block-inst var-inst make-var-inst
	  function-inst make-function-inst set-inst make-set-inst
	  return-inst make-return-inst expr-inst make-expr-inst
	  inst-decls inst-body inst-name inst-type inst-init inst-var
	  inst-expr))

(definst var (stream) (name type init)
  (pprint-c-type type stream name)
  (when init
    (format stream " = ~A" init)))
(definst set (stream) (var expr)
  (format stream "~@<~A = ~@_~2I~A;~:>" var expr))
(definst return (stream) (expr)
  (format stream "return~@[ (~A)~];" expr))
(definst expr (stream) (expr)
  (format stream "~A;" expr))
(definst block (stream) (decls body)
  (format stream "{~:@_~@<  ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
	  decls body))
(definst function (stream) (name type body)
  (pprint-logical-block (stream nil)
    (princ "static " stream)
    (pprint-c-type type stream name)
    (format stream "~:@_~A~:@_~:@_" body)))

;; Formatting utilities.

(defun format-compound-statement* (stream child morep thunk)
  "Underlying function for FORMAT-COMPOUND-STATEMENT."
  (cond ((typep child 'block-inst)
	 (funcall thunk stream)
	 (write-char #\space stream)
	 (princ child stream)
	 (when morep (write-char #\space stream)))
	(t
	 (pprint-logical-block (stream nil)
	   (funcall thunk stream)
	   (write-char #\space stream)
	   (pprint-indent :block 2 stream)
	   (pprint-newline :linear stream)
	   (princ child stream)
	   (pprint-indent :block 0 stream)
	   (case morep
	     (:space
	      (write-char #\space stream)
	      (pprint-newline :linear stream))
	     ((t)
	      (pprint-newline :mandatory stream)))))))

(export 'format-compound-statement)
(defmacro format-compound-statement
    ((stream child &optional morep) &body body)
  "Format a compound statement to STREAM.

   The introductory material is printed by BODY.  The CHILD is formatted
   properly according to whether it's a BLOCK-INST.  If MOREP is true, then
   allow for more stuff following the child."
  `(format-compound-statement* ,stream ,child ,morep
			       (lambda (,stream) ,@body)))

;;;--------------------------------------------------------------------------
;;; Code generation.

;; Accessors.

(export 'codegen-functions)
(defgeneric codegen-functions (codegen)
  (:documentation
   "Return the list of FUNCTION-INSTs of completed functions."))

(export 'ensure-var)
(defgeneric ensure-var (codegen name type &optional init)
  (:documentation
   "Add a variable to CODEGEN's list.

   The variable is called NAME (which should be comparable using EQUAL and
   print to an identifier) and has the given TYPE.  If INIT is present and
   non-nil it is an expression INST used to provide the variable with an
   initial value."))

(export '(emit-inst emit-insts))
(defgeneric emit-inst (codegen inst)
  (:documentation
   "Add INST to the end of CODEGEN's list of instructions."))
(defgeneric emit-insts (codegen insts)
  (:documentation
   "Add a list of INSTS to the end of CODEGEN's list of instructions.")
  (:method (codegen insts)
    (dolist (inst insts) (emit-inst codegen inst))))

(export 'codegen-push)
(defgeneric codegen-push (codegen)
  (:documentation
   "Pushes the current code generation state onto a stack.

   The state consists of the accumulated variables and instructions."))

(export 'codegen-pop)
(defgeneric codegen-pop (codegen)
  (:documentation
   "Pops a saved state off of the CODEGEN's stack.

   Returns the newly accumulated variables and instructions as lists, as
   separate values."))

(export 'codegen-add-function)
(defgeneric codegen-add-function (codegen function)
  (:documentation
   "Adds a function to CODEGEN's list.

   Actually, we're not picky: FUNCTION can be any kind of object that you're
   willing to find in the list returned by CODEGEN-FUNCTIONS."))

(export 'temporary-var)
(defgeneric temporary-var (codegen type)
  (:documentation
   "Return the name of a temporary variable.

   The temporary variable will have the given TYPE, and will be marked
   in-use.  You should clear the in-use flag explicitly when you've finished
   with the variable -- or, better, use WITH-TEMPORARY-VAR to do the cleanup
   automatically."))

(export 'codegen-build-function)
(defun codegen-build-function (codegen name type vars insts)
  "Build a function and add it to CODEGEN's list.

   Returns the function's name."
  (codegen-add-function codegen
			(make-function-inst name type
					    (make-block-inst vars insts)))
  name)

(export 'codegen-pop-block)
(defgeneric codegen-pop-block (codegen)
  (:documentation
   "Makes a block (BLOCK-INST) out of the completed code in CODEGEN.")
  (:method (codegen)
    (multiple-value-bind (vars insts) (codegen-pop codegen)
      (make-block-inst vars insts))))

(export 'codegen-pop-function)
(defgeneric codegen-pop-function (codegen name type)
  (:documentation
   "Makes a function out of the completed code in CODEGEN.

   The NAME can be any object you like.  The TYPE should be a function type
   object which includes argument names.  The return value is the NAME.")
  (:method (codegen name type)
    (multiple-value-bind (vars insts) (codegen-pop codegen)
      (codegen-build-function codegen name type vars insts))))

(export 'with-temporary-var)
(defmacro with-temporary-var ((codegen var type) &body body)
  "Evaluate BODY with VAR bound to a temporary variable name.

   During BODY, VAR will be marked in-use; when BODY ends, VAR will be marked
  available for re-use."
  `(let ((,var (temporary-var ,codegen ,type)))
     (unwind-protect
	  (progn ,@body)
       (setf (var-in-use-p ,var) nil))))

;;;--------------------------------------------------------------------------
;;; Code generation idioms.

(export 'deliver-expr)
(defun deliver-expr (codegen target expr)
  "Emit code to deliver the value of EXPR to the TARGET.

   The TARGET may be one of the following.

     * :VOID, indicating that the value is to be discarded.  The expression
       will still be evaluated.

     * :VOID-RETURN, indicating that the value is to be discarded (as for
       :VOID) and furthermore a `return' from the current function should be
       forced after computing the value.

     * :RETURN, indicating that the value is to be returned from the current
       function.

     * A variable name, indicating that the value is to be stored in the
       variable.

   In the cases of :RETURN, :VOID and :VOID-RETURN targets, it is valid for
   EXPR to be nil; this signifies that no computation needs to be performed.
   Variable-name targets require an expression."

  (case target
    (:return (emit-inst codegen (make-return-inst expr)))
    (:void (when expr (emit-inst codegen (make-expr-inst expr))))
    (:void-return (when expr (emit-inst codegen (make-expr-inst expr)))
		  (emit-inst codegen (make-return-inst nil)))
    (t (emit-inst codegen (make-set-inst target expr)))))

(export 'convert-stmts)
(defun convert-stmts (codegen target type func)
  "Invoke FUNC to deliver a value to a non-:RETURN target.

   FUNC is a function which accepts a single argument, a non-:RETURN target,
   and generates statements which deliver a value (see DELIVER-EXPR) of the
   specified TYPE to this target.  In general, the generated code will have
   the form

     setup instructions...
     (DELIVER-EXPR CODEGEN TARGET (compute value...))
     cleanup instructions...

   where the cleanup instructions are essential to the proper working of the
   generated program.

   CONVERT-STMTS will call FUNC to generate code, and arrange that its value
   is correctly delivered to TARGET, regardless of what the TARGET is --
   i.e., it lifts the restriction to non-:RETURN targets.  It does this by
   inventing a new temporary variable."

  (case target
    (:return (with-temporary-var (codegen var type)
	       (funcall func var)
	       (deliver-expr codegen target var)))
    (:void-return (funcall func :void)
		  (emit-inst codegen (make-return-inst nil)))
    (t (funcall func target))))

;;;----- That's all, folks --------------------------------------------------