;;; -*-lisp-*-
;;;
;;; Code generator for effective methods
;;;
;;; (c) 2009 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Simple Object Definition system.
;;;
;;; 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.

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

(defclass temporary-argument (temporary-name) ())
(defclass temporary-function (temporary-name) ())

(defclass temporary-variable (temporary-name)
  ((in-use-p :initarg :in-use-p :initform nil
	     :type boolean :accessor var-in-use-p)))

(defmethod var-in-use-p ((var t))
  "Non-temporary variables are always in use."
  t)

(defmethod commentify-argument-name ((name temporary-name))
  nil)

(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.")

(defun temporary-function ()
  "Return a temporary function name."
  (make-instance 'temporary-function
		 :tag (prog1 *temporary-index* (incf *temporary-index*))))

(defgeneric format-temporary-name (var stream)
  (:method ((var temporary-name) stream)
    (format stream "~A" (temp-tag var)))
  (:method ((var temporary-argument) stream)
    (format stream "sod__a~A" (temp-tag var)))
  (:method ((var temporary-variable) stream)
    (format stream "sod__v~A" (temp-tag var)))
  (:method ((var temporary-function) stream)
    (format stream "sod__f~A" (temp-tag var))))

(defmethod print-object ((var temporary-name) stream)
  (if *print-escape*
      (print-unreadable-object (var stream :type t)
	(prin1 (temp-tag var) stream))
      (format-temporary-name var stream)))

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

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

(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."))

(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))

(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)))))))

(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)))))))

(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)))

;;;--------------------------------------------------------------------------
;;; Instruction types.

;; Compound statements.

(definst block (stream) (decls body)
  (format stream "{~:@_~@<  ~2I~@[~{~A;~:@_~}~:@_~]~{~A~^~:@_~}~:>~:@_}"
	  decls body))

(definst if (stream) (condition consequent alternative)
  (format-compound-statement (stream consequent alternative)
    (format stream "if (~A)" condition))
  (when alternative
    (format-compound-statement (stream alternative)
      (write-string "else" stream))))

(definst while (stream) (condition body)
  (format-compound-statement (stream body)
    (format stream "while (~A)" condition)))

(definst do-while (stream) (body condition)
  (format-compound-statement (stream body :space)
    (write-string "do" stream))
  (format stream "while (~A);" condition))

;; Simple statements.

(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))

;; Special varargs hacks.

(definst va-start (stream) (ap arg)
  (format stream "va_start(~@<~A, ~_~A~:>);" ap arg))

(definst va-copy (stream) (to from)
  (format stream "va_copy(~@<~A, ~_~A~:>);" to from))

(definst va-end (stream) (ap)
  (format stream "va_end(~A);" ap))

;; Declarations.  These should appear at the heads of BLOCK-INSTs.

(definst var (stream) (name type init)
  (pprint-c-type type stream name)
  (when init
    (format stream " = ~A" init)))

;; Expressions.

(definst call (stream) (func args)
  (format stream "~A(~@<~{~A~^, ~_~}~:>)" func args))

;; Top level things.

(definst function (stream) (name type body)
  (pprint-logical-block (stream nil)
    (pprint-c-type type stream name)
    (format stream "~:@_~A~:@_~:@_" body)))

;;;--------------------------------------------------------------------------
;;; Code generator objects.

(defclass basic-codegen ()
  ((vars :initarg :vars :initform nil :type list :accessor codegen-vars)
   (insts :initarg :insts :initform nil :type list :accessor codegen-insts)
   (temp-index :initarg :temp-index :initform 0
	       :type fixnum :accessor codegen-temp-index))
  (:documentation
   "Base class for code generator state.

   This contains the bare essentials for supporting the EMIT-INST and
   ENSURE-VAR protocols; see the documentation for those generic functions
   for more details.

   This class isn't abstract.  A full CODEGEN object uses instances of this
   to keep track of pending functions which haven't been completed yet.

   Just in case that wasn't clear enough: this is nothing to do with the
   BASIC language."))

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

(defgeneric emit-insts (codegen insts)
  (:documentation
   "Add a list of INSTS to the end of CODEGEN's list of instructions.")
  (:method ((codegen basic-codegen) insts)
    (setf (codegen-insts codegen)
	  (revappend insts (codegen-insts codegen)))))

(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.")
  (:method ((codegen basic-codegen) name type &optional init)
    (let* ((vars (codegen-vars codegen))
	   (var (find name vars :key #'inst-name :test #'equal)))
      (cond ((not var)
	     (setf (codegen-vars codegen)
		   (cons (make-var-inst name type init) vars)))
	    ((not (c-type-equal-p type (inst-type var)))
	     (error "(Internal) Redefining type for variable ~A." name)))
      name)))

(defclass codegen (basic-codegen)
  ((functions :initform nil :type list :accessor codegen-functions)
   (stack :initform nil :type list :accessor codegen-stack))
  (:documentation
   "A full-fat code generator which can generate and track functions.

   This is the real deal.  Subclasses may which to attach additional state
   for convenience's sake, but this class is self-contained.  It supports the
   CODEGEN-PUSH, CODEGEN-POP and CODEGEN-POP-FUNCTION protocols."))

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

   The state consists of the accumulated variables and instructions, i.e.,
   what is representable by a BASIC-CODEGEN.")
  (:method ((codegen codegen))
    (with-slots (vars insts temp-index stack) codegen
      (push (make-instance 'basic-codegen
			   :vars vars
			   :insts insts
			   :temp-index temp-index)
	    stack)
      (setf vars nil insts nil temp-index 0))))

(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.")
  (:method ((codegen codegen))
    (with-slots (vars insts temp-index stack) codegen
      (multiple-value-prog1
	  (values (nreverse vars) (nreverse insts))
	(let ((sub (pop stack)))
	  (setf vars (codegen-vars sub)
		insts (codegen-insts sub)
		temp-index (codegen-temp-index sub)))))))

(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.")
  (:method ((codegen codegen) function)
    (with-slots (functions) codegen
      (setf functions (nconc functions (list 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)

(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 codegen) name type)
    (multiple-value-bind (vars insts) (codegen-pop codegen)
      (codegen-build-function codegen name type vars insts))))

(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."))

(defmethod temporary-var ((codegen basic-codegen) type)
  (with-slots (vars temp-index) codegen
    (or (find-if (lambda (var)
		   (and (not (var-in-use-p (inst-name var)))
			(c-type-equal-p type (inst-type var))))
		 vars)
	(let* ((name (make-instance 'temporary-variable
				    :tag (prog1 temp-index
					   (incf temp-index)))))
	  (push (make-var-inst name type nil) vars)
	  name))))

(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.

(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)))))

(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 --------------------------------------------------