;;; -*-lisp-*-
;;;
;;; Aggregating method combinations
;;;
;;; (c) 2015 Straylight/Edgeware
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This file is part of the Sensible 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)

;;;--------------------------------------------------------------------------
;;; Classes and protocol.

(export '(aggregating-message
	  sod-message-combination sod-message-kernel-function))
(defclass aggregating-message (simple-message)
  ((combination :initarg :combination :type keyword
		:reader sod-message-combination)
   (plist :type list :accessor sod-message-plist)
   (kernel-function :type function :reader sod-message-kernel-function))
  (:documentation
   "Message class for aggregating method combinations.

   An aggregating method combination invokes the primary methods in order,
   most-specific first, collecting their return values, and combining them
   together in some way to produce a result for the effective method as a
   whole.

   Mostly, this is done by initializing an accumulator to some appropriate
   value, updating it with the result of each primary method in turn, and
   finally returning some appropriate output function of it.  The order is
   determined by the `:most-specific' property, which may have the value
   `:first' or `:last'.

   The `progn' method combination is implemented as a slightly weird special
   case of an aggregating method combination with a trivial state.  More
   typical combinations are `:sum', `:product', `:min', `:max', `:and', and
   `:or'.  Finally, there's a `custom' combination which uses user-supplied
   code fragments to stitch everything together."))

(export 'aggregating-message-properties)
(defgeneric aggregating-message-properties (message combination)
  (:documentation
   "Return a description of the properties needed by the method COMBINATION.

   The description should be a plist of alternating property name and type
   keywords.  The named properties will be looked up in the pset supplied at
   initialization time, and supplied to `compute-aggregating-message-kernel'
   as keyword arguments.  Defaults can be supplied in method BVLs.

   The default is not to capture any property values.

   The reason for this is as not to retain the pset beyond message object
   initialization.")
  (:method (message combination) nil))

(export 'compute-aggregating-message-kernel)
(defgeneric compute-aggregating-message-kernel
    (message combination codegen target methods arg-names &key)
  (:documentation
   "Determine how to aggregate the direct methods for an aggregating message.

   The return value is a function taking arguments (CODEGEN TARGET ARG-NAMES
   METHODS): it should emit, to CODEGEN, an appropriate effective-method
   kernel which invokes the listed direct METHODS, in the appropriate order,
   collects and aggregates their values, and delivers to TARGET the final
   result of the method kernel.

   The easy way to implement this method is to use the macro
   `define-aggregating-method-combination'."))

(export 'check-aggregating-message-type)
(defgeneric check-aggregating-message-type (message combination type)
  (:documentation
   "Check that TYPE is an acceptable function TYPE for the COMBINATION.

   For example, `progn' messages must return `void', while `and' and `or'
   messages must return `int'.")
  (:method (message combination type)
    t))

(defgeneric aggregating-message-method-return-type (message combination)
  (:documentation
   "Return the primary method return type for this MESSAGE and COMBINATION.")
  (:method ((message aggregating-message) (combination t))
    (c-type-subtype (sod-message-type message))))

(export 'aggregating-effective-method)
(defclass aggregating-effective-method (simple-effective-method) ()
  (:documentation "Effective method counterpart to `aggregating-message'."))

(defgeneric aggregating-message-always-live-p (message combination)
  (:documentation
   "Return whether the method combination can work without primary methods.

   Return non-nil if the corresponding effective method should be considered
   live even if it doesn't have any methods.")
  (:method ((message aggregating-message) (combination t)) nil))

(defmethod effective-method-live-p ((method aggregating-effective-method))
  (or (let* ((message (effective-method-message method))
	     (comb (sod-message-combination message)))
	(aggregating-message-always-live-p message comb))
      (call-next-method)))

;;;--------------------------------------------------------------------------
;;; Implementation.

(defmethod check-message-type ((message aggregating-message) type)
  (with-slots (combination) message
    (check-aggregating-message-type message combination type)))

(defmethod sod-message-effective-method-class ((message aggregating-message))
  'aggregating-effective-method)

(defmethod simple-method-body
    ((method aggregating-effective-method) codegen target)
  (let ((argument-names (effective-method-basic-argument-names method))
	(primary-methods (effective-method-primary-methods method)))
    (funcall (sod-message-kernel-function (effective-method-message method))
	     codegen target argument-names primary-methods)))

(defmethod shared-initialize :before
    ((message aggregating-message) slot-names &key pset)
  (declare (ignore slot-names))
  (with-slots (combination plist kernel-function) message
    (let ((most-specific (get-property pset :most-specific :keyword :first))
	  (comb (get-property pset :combination :keyword)))

      ;; Check that we've been given a method combination and make sure it
      ;; actually exists.
      (unless comb
	(error "The `combination' property is required."))
      (unless (some (lambda (method)
		      (let* ((specs (method-specializers method))
			     (message-spec (car specs))
			     (combination-spec (cadr specs)))
			(and (typep message-spec 'class)
			     (typep message message-spec)
			     (typep combination-spec 'eql-specializer)
			     (eq (eql-specializer-object combination-spec)
				 comb))))
		    (generic-function-methods
		     #'compute-aggregating-message-kernel))
	(error "Unknown method combination `~(~A~)'." comb))
      (setf combination comb)

      ;; Make sure the ordering is actually valid.
      (unless (member most-specific '(:first :last))
	(error "The `most_specific' property must be `first' or `last'."))

      ;; Set up the function which will compute the kernel.
      (let ((magic (cons nil nil))
	    (keys nil))

	;; Collect the property values wanted by the method combination.
	(do ((want (aggregating-message-properties message comb)
		   (cddr want)))
	    ((endp want))
	  (let* ((name (car want))
		 (type (cadr want))
		 (prop (get-property pset name type magic)))
	    (unless (eq prop magic)
	      (setf keys (list* name prop keys)))))
	(setf plist keys)

	;; Set the kernel function for later.
	(setf kernel-function
	      (lambda (codegen target arg-names methods)
		(apply #'compute-aggregating-message-kernel
		       message comb
		       codegen target
		       (ecase most-specific
			 (:first methods)
			 (:last (setf methods (reverse methods))))
		       arg-names
		       plist)))))))

(defmethod check-method-type
    ((method sod-method) (message aggregating-message)
     (type c-function-type))
  (let ((wanted (aggregating-message-method-return-type
		 message (sod-message-combination message)))
	(msgtype (sod-message-type message)))
    (check-method-return-type type wanted)
    (check-method-argument-lists type msgtype)))

;;;--------------------------------------------------------------------------
;;; Utilities.

(export 'define-aggregating-method-combination)
(defmacro define-aggregating-method-combination
    (comb
     (vars
      &key (codegen (gensym "CODEGEN-"))
	   (methods (gensym "METHODS-")))
     &key properties return-type
	  ((:around around-func) '#'funcall)
	  ((:empty empty-func) nil emptyp)
	  ((:first-method first-method-func) nil firstp)
	  ((:methods methods-func) '#'funcall))
  "Utility macro for definining aggregating method combinations.

   The VARS are a list of variable names to be bound to temporary variable
   objects of the method's return type.  Additional keyword arguments define
   variables names to be bound to other possibly interesting values:

     * CODEGEN is the `codegen' object passed at effective-method computation
       time; and

     * METHODS is the list of primary methods, in the order in which they
       should be invoked.  Note that this list must be non-empty, since
       otherwise the method on `compute-effective-method-body' specialized to
       `simple-effective-method' will suppress the method entirely.

   The PROPERTIES, if specified, are a list of properties to be collected
   during message-object initialization; items in the list have the form

	   (([KEYWORD] NAME) TYPE [DEFAULT] [SUPPLIEDP])

   similar to a `&key' BVL entry, except for the additional TYPE entry.  In
   particular, a symbolic NAME may be written in place of a singleton list.
   The KEYWORD names the property as it should be looked up in the pset,
   while the NAME names a variable to which the property value or default is
   bound.

   All of these variables, and the VARS, are available in the functions
   described below.

   If a RETURN-TYPE is given, it's a C-type S-expression: a method is defined
   on `check-aggregating-message-type' to check the that the message's return
   type matches RETURN-TYPE.

   If an EMPTY function is given, then (a) it's OK if there are no primary
   methods, because (b) the EMPTY function is called to set the return
   value variable in this case.  Note that EMPTY is only called when there
   are no primary methods.

   The AROUND, FIRST-METHOD, and METHODS are function designators (probably
   `lambda' forms) providing pieces of the aggregating behaviour.

   The AROUND function is called first, with a single argument BODY, though
   the variables above are also in scope.  It is expected to emit code to
   CODEGEN which invokes the METHODS in the appropriate order, and arranges
   to store the aggregated return value in the first of the VARS.

   It may call BODY as a function in order to assist with this; let ARGS be
   the list of arguments supplied to it.  The default behaviour is to call
   BODY with no arguments.  The BODY function first calls FIRST-METHOD,
   passing it as arguments a function INVOKE and the ARGS which were passed
   to BODY, and then calls METHODS once for each remaining method, again
   passing an INVOKE function and the ARGS.  If FIRST-METHOD is not
   specified, then the METHODS function is used for all of the methods.  If
   METHODS is not specified, then the behaviour is simply to call INVOKE
   immediately.  (See the definition of the `:progn' method combination.)

   Calling (funcall INVOKE [TARGET]) emits instructions to CODEGEN to call
   the appropriate direct method and deliver its return value to TARGET,
   which defaults to `:void'."

  (with-gensyms (type msg combvar target arg-names args want-type
		 meth targ func call-methfunc
		 aroundfunc fmethfunc methfunc bodyfunc)
    `(progn

       ;; If properties are listed, arrange for them to be collected.
       ,@(and properties
	      `((defmethod aggregating-message-properties
		    ((,msg aggregating-message) (,combvar (eql ',comb)))
		  ',(mapcan (lambda (prop)
			      (list (let* ((name (car prop))
					   (names (if (listp name) name
						      (list name))))
				      (if (cddr names) (car names)
					  (intern (car names) :keyword)))
				    (cadr prop)))
			    properties))))

       ;; If a particular return type is wanted, check that.
       ,@(and return-type
	      `((defmethod check-aggregating-message-type
		    ((,msg aggregating-message)
		     (,combvar (eql ',comb))
		     (,type c-function-type))
		  (let ((,want-type (c-type ,return-type)))
		    (unless (c-type-equal-p (c-type-subtype ,type)
					    ,want-type)
		      (error "Messages with `~(~A~)' combination ~
			      must return `~A'."
			     ,combvar ,want-type)))
		  (call-next-method))))

       ;; If there is an EMPTY function then the effective method is always
       ;; live.
       ,@(and emptyp
	      `((defmethod aggregating-message-always-live-p
		    ((,msg aggregating-message)
		     (,combvar (eql ',comb)))
		  t)))

       ;; Define the main kernel-compuation method.
       (defmethod compute-aggregating-message-kernel
	   ((,msg aggregating-message) (,combvar (eql ',comb))
	    ,codegen ,target ,methods ,arg-names
	    &key ,@(mapcar (lambda (prop) (cons (car prop) (cddr prop)))
			   properties))
	 (declare (ignore ,combvar))

	 ;; Declare the necessary variables and give names to the functions
	 ;; supplied by the caller.
	 (let* (,@(and vars
		       `((,type (c-type-subtype (sod-message-type ,msg)))
			 (,(car vars) (temporary-var ,codegen ,type))))
		,@(mapcar (lambda (var)
			    (list var `(and ,methods
					    (temporary-var ,codegen ,type))))
			  (cdr vars))
		(,aroundfunc ,around-func)
		(,methfunc ,methods-func)
		(,fmethfunc ,(if firstp first-method-func methfunc)))

	   (flet ((,bodyfunc ()
		    (funcall ,aroundfunc
			     (lambda (&rest ,args)
			       (flet ((,call-methfunc (,func ,meth)
					;; Call FUNC, passing it an INVOKE
					;; function which will generate a
					;; call to METH.
					(apply ,func
					       (lambda
						   (&optional (,targ :void))
						 (invoke-method ,codegen
								,targ
								,arg-names
								,meth))
					       ,args)))

				 ;; The first method might need special
				 ;; handling.
				 (,call-methfunc ,fmethfunc (car ,methods))

				 ;; Call the remaining methods in the right
				 ;; order.
				 (dolist (,meth (cdr ,methods))
				   (,call-methfunc ,methfunc ,meth)))))))

	     ;; Arrange to release the temporaries when we're finished with
	     ;; them.
	     (unwind-protect
		  (progn

		    ;; If there are no direct methods, then just do the
		    ;; empty-effective-method thing to set the return
		    ;; variable.  Otherwise, wrap AROUND round the main body.
		    ,(if emptyp
			 `(if (null ,methods)
			      (funcall ,empty-func)
			      (,bodyfunc))
			 `(,bodyfunc))

		  ;; Outside the AROUND function now, deliver the final
		  ;; result to the right place.
		  (deliver-expr ,codegen ,target ,(car vars)))

	       ;; Finally, release the temporary variables.
	       ,@(mapcar (lambda (var)
			   `(when ,var (setf (var-in-use-p ,var) nil)))
			 vars)))))

       ',comb)))

;;;--------------------------------------------------------------------------
;;; Fixed aggregating method combinations.

(define-aggregating-method-combination :progn (nil)
  :return-type void
  :empty (lambda () nil))

(define-aggregating-method-combination :sum ((acc val) :codegen codegen)
  :empty (lambda () (emit-inst codegen (make-set-inst acc 0)))
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-update-inst acc #\+ val))))

(define-aggregating-method-combination :product ((acc val) :codegen codegen)
  :empty (lambda () (emit-inst codegen (make-set-inst acc 1)))
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-update-inst acc #\* val))))

(define-aggregating-method-combination :min ((acc val) :codegen codegen)
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-if-inst (format nil "~A > ~A" acc val)
					      (make-set-inst acc val)))))

(define-aggregating-method-combination :max ((acc val) :codegen codegen)
  :first-method (lambda (invoke)
		  (funcall invoke val)
		  (emit-inst codegen (make-set-inst acc val)))
  :methods (lambda (invoke)
	     (funcall invoke val)
	     (emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
					      (make-set-inst acc val)))))

(define-aggregating-method-combination :and ((ret) :codegen codegen)
  :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))
  :around (lambda (body)
	    (codegen-push codegen)
	    (funcall body)
	    (emit-inst codegen
		       (make-do-while-inst (codegen-pop-block codegen) 0)))
  :methods (lambda (invoke)
	     (funcall invoke ret)
	     (emit-inst codegen (make-if-inst (format nil "!~A" ret)
					      (make-break-inst)))))

(define-aggregating-method-combination :or ((ret) :codegen codegen)
  :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))
  :around (lambda (body)
	    (codegen-push codegen)
	    (funcall body)
	    (emit-inst codegen
		       (make-do-while-inst (codegen-pop-block codegen) 0)))
  :methods (lambda (invoke)
	     (funcall invoke ret)
	     (emit-inst codegen (make-if-inst ret (make-break-inst)))))

;;;--------------------------------------------------------------------------
;;; A customizable aggregating method combination.

(defmethod aggregating-message-properties
    ((message aggregating-message) (combination (eql :custom)))
  '(:retvar :id
    :valvar :id
    :methty :type
    :empty :fragment
    :decls :fragment
    :before :fragment
    :first :fragment
    :each :fragment
    :after :fragment
    :count :id))

(defmethod aggregating-message-method-return-type
    ((message aggregating-message) (combination (eql :custom)))
  (getf (sod-message-plist message) :methty
	(c-type-subtype (sod-message-type message))))

(defmethod aggregating-message-always-live-p
    ((message aggregating-message) (combination (eql :custom)))
  (getf (sod-message-plist message) :empty))

(defmethod compute-aggregating-message-kernel
    ((message aggregating-message) (combination (eql :custom))
     codegen target methods arg-names
     &key (retvar "sod_ret") (valvar "sod_val") (methty nil methtyp)
	  empty decls before each (first each) after count)
  (let* ((type (c-type-subtype (sod-message-type message)))
	 (methty (if methtyp methty type)))
    (unless (eq type c-type-void)
      (ensure-var codegen retvar type))
    (unless (or (null methods)
		(eq methty c-type-void))
      (ensure-var codegen valvar methty))
    (when (and methods count)
      (ensure-var codegen count c-type-size-t (length methods)))
    (when (and methods decls)
      (emit-decl codegen decls))
    (labels ((maybe-emit (fragment)
	       (when fragment (emit-inst codegen fragment)))
	     (invoke (method fragment)
	       (invoke-method codegen
			      (if (eq methty c-type-void) :void valvar)
			      arg-names method)
	       (maybe-emit fragment)))
      (cond ((and empty (null methods))
	     (emit-inst codegen empty))
	    (t
	     (maybe-emit before)
	     (invoke (car methods) first)
	     (dolist (method (cdr methods)) (invoke method each))
	     (maybe-emit after)))
      (deliver-expr codegen target retvar))))

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