(defmethod slot-unbound (class
(message basic-message)
(slot-name (eql 'argument-tail)))
+ (declare (ignore class))
(let ((seq 0))
(setf (slot-value message 'argument-tail)
(mapcar (lambda (arg)
(defmethod slot-unbound (class
(message basic-message)
(slot-name (eql 'no-varargs-tail)))
+ (declare (ignore class))
(setf (slot-value message 'no-varargs-tail)
(mapcar (lambda (arg)
(if (eq arg :ellipsis)
"Base class for messages with `simple' method combinations.
A simple method combination is one which has only one method role other
- than the `before', `after' and `around' methods provided by BASIC-MESSAGE.
- We call these `primary' methods, and the programmer designates them by not
- specifying an explicit role.
+ than the `before', `after' and `around' methods provided by
+ `basic-message'. We call these `primary' methods, and the programmer
+ designates them by not specifying an explicit role.
If the programmer doesn't define any primary methods then the effective
method is null -- i.e., the method entry pointer shows up as a null
(call-next-method)
(primary-method-class message)))
+(defmethod primary-method-class ((message simple-message))
+ 'basic-direct-method)
+
;;;--------------------------------------------------------------------------
;;; Direct method classes.
(defmethod slot-unbound
(class (method basic-direct-method) (slot-name (eql 'function-type)))
+ (declare (ignore class))
(let ((type (sod-method-type method)))
(setf (slot-value method 'function-type)
(c-type (fun (lisp (c-type-subtype type))
(defmethod slot-unbound (class
(method delegating-direct-method)
(slot-name (eql 'next-method-type)))
+ (declare (ignore class))
(let* ((message (sod-method-message method))
(type (sod-message-type message)))
(setf (slot-value method 'next-method-type)
(c-type (fun (lisp (c-type-subtype type))
("me" (* (class (sod-method-class method))))
- . (c-function-arguments type))))))
+ .
+ (c-function-arguments type))))))
(defmethod slot-unbound (class
(method delegating-direct-method)
(slot-name (eql 'function-type)))
+ (declare (ignore class))
(let* ((message (sod-method-message method))
(type (sod-method-type method))
(method-args (c-function-arguments type)))
(defmethod slot-unbound (class
(method basic-effective-method)
(slot-name (eql 'basic-argument-names)))
+ (declare (ignore class))
(let ((message (effective-method-message method)))
(setf (slot-value method 'basic-argument-names)
(subst *sod-master-ap* *sod-ap*
(defmethod slot-unbound
(class (method basic-effective-method) (slot-name (eql 'functions)))
+ (declare (ignore class))
(setf (slot-value method 'functions)
(compute-method-entry-functions method)))
(defmethod shared-initialize :after
((codegen method-codegen) slot-names &key)
+ (declare (ignore slot-names))
(with-slots (message target) codegen
(setf target
(if (eq (c-type-subtype (sod-message-type message)) (c-type void))
method
(let* ((message-type (sod-message-type message))
(return-type (c-type-subtype message-type))
- (voidp (eq return-type (c-type void)))
(basic-tail (effective-method-basic-argument-names method)))
(flet ((method-kernel (target)
(dolist (before before-methods)
(invoke-method codegen :void basic-tail before))
- (if (or voidp (null after-methods))
+ (if (null after-methods)
(funcall body target)
(convert-stmts codegen target return-type
(lambda (target)
(funcall body target)
(dolist (after (reverse after-methods))
(invoke-method codegen :void
- after basic-tail)))))))
+ basic-tail after)))))))
(invoke-delegation-chain codegen target basic-tail
around-methods #'method-kernel)))))
(emf-type (c-type (fun (lisp return-type)
("sod__obj" (lisp ilayout-type))
. (sod-message-no-varargs-tail message))))
- (result (if (eq return-type (c-type void)) nil
- (temporary-var codegen return-type)))
- (emf-target (or result :void))
;; Method entry details.
(chain-tails (remove-if-not (lambda (super)
;; Generate the method body. We'll work out what to do with it later.
(codegen-push codegen)
- (compute-effective-method-body method codegen emf-target)
- (multiple-value-bind (vars insts) (codegen-pop codegen)
- (cond ((or (= n-entries 1)
- (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
- *method-entry-inline-threshold*))
-
- ;; The effective method body is simple -- or there's only one
- ;; of them. We'll inline the method body into the entry
- ;; functions.
- (dolist (tail chain-tails)
- (setup-entry tail)
- (dolist (var vars)
- (ensure-var codegen (inst-name var)
- (inst-type var) (inst-init var)))
- (when parm-n (varargs-prologue))
- (emit-insts codegen insts)
- (when parm-n (varargs-epilogue))
- (deliver-expr codegen entry-target result)
- (finish-entry tail)))
-
- (t
-
- ;; The effective method body is complicated and we'd need more
- ;; than one copy. We'll generate an effective method function
- ;; and call it a lot.
- (codegen-build-function codegen emf-name emf-type vars
- (nconc insts (and result (list (make-return-inst result)))))
-
- (let ((call (make-call-inst emf-name
- (cons "sod__obj" (mapcar #'argument-name
- emf-arg-tail)))))
+ (let* ((result (if (eq return-type c-type-void) nil
+ (temporary-var codegen return-type)))
+ (emf-target (or result :void)))
+ (compute-effective-method-body method codegen emf-target)
+ (multiple-value-bind (vars insts) (codegen-pop codegen)
+ (cond ((or (= n-entries 1)
+ (<= (* n-entries (reduce #'+ insts :key #'inst-metric))
+ *method-entry-inline-threshold*))
+
+ ;; The effective method body is simple -- or there's only
+ ;; one of them. We'll inline the method body into the entry
+ ;; functions.
(dolist (tail chain-tails)
(setup-entry tail)
- (cond (parm-n
- (varargs-prologue)
- (convert-stmts codegen entry-target return-type
- (lambda (target)
- (deliver-expr codegen target call)
- (varargs-epilogue))))
- (t
- (deliver-expr codegen entry-target call)))
- (finish-entry tail))))))
+ (dolist (var vars)
+ (if (typep var 'var-inst)
+ (ensure-var codegen (inst-name var)
+ (inst-type var) (inst-init var))
+ (emit-decl codegen var)))
+ (when parm-n (varargs-prologue))
+ (emit-insts codegen insts)
+ (when parm-n (varargs-epilogue))
+ (deliver-expr codegen entry-target result)
+ (finish-entry tail)))
+
+ (t
+
+ ;; The effective method body is complicated and we'd need
+ ;; more than one copy. We'll generate an effective method
+ ;; function and call it a lot.
+ (codegen-build-function codegen emf-name emf-type vars
+ (nconc insts (and result
+ (list (make-return-inst result)))))
+
+ (let ((call (make-call-inst emf-name
+ (cons "sod__obj" (mapcar #'argument-name
+ emf-arg-tail)))))
+ (dolist (tail chain-tails)
+ (setup-entry tail)
+ (cond (parm-n
+ (varargs-prologue)
+ (convert-stmts codegen entry-target return-type
+ (lambda (target)
+ (deliver-expr codegen
+ target call)
+ (varargs-epilogue))))
+ (t
+ (deliver-expr codegen entry-target call)))
+ (finish-entry tail)))))))
(codegen-functions codegen))))
(defmethod compute-effective-method-body
((method simple-effective-method) codegen target)
- (with-slots (message basic-argument-names primary-methods) method
- (basic-effective-method-body codegen target method
- (lambda (target)
- (simple-method-body method
- codegen
- target)))))
+ (basic-effective-method-body codegen target method
+ (lambda (target)
+ (simple-method-body method
+ codegen
+ target))))
;;;--------------------------------------------------------------------------
;;; Standard method combination.
(defclass standard-message (simple-message)
()
(:documentation
- "Message class for standard method combination.
+ "Message class for standard method combinations.
Standard method combination is a simple method combination where the
primary methods are invoked as a delegation chain, from most- to
(effective-method-primary-methods method)
nil))
+;;;--------------------------------------------------------------------------
+;;; Aggregate method combinations.
+
+(export 'aggregating-message)
+(defclass aggregating-message (simple-message)
+ ((combination :initarg :combination :type keyword
+ :reader message-combination)
+ (kernel-function :type function :reader 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'."))
+
+(defmethod shared-initialize :before
+ ((message aggregating-message) slot-names &key pset)
+ (declare (ignore slot-names))
+ (with-slots (combination 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)))))
+
+ ;; 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
+ keys)))))))
+
+(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))
+
+(defmethod check-message-type ((message aggregating-message) type)
+ (with-slots (combination) message
+ (check-aggregating-message-type message combination type)))
+
+(flet ((check (comb want type)
+ (unless (eq (c-type-subtype type) want)
+ (error "Messages with `~A' combination must return `~A'."
+ (string-downcase comb) want))))
+ (defmethod check-aggregating-message-type
+ ((message aggregating-message)
+ (combination (eql :progn))
+ (type c-function-type))
+ (check combination c-type-void type)
+ (call-next-method))
+ (defmethod check-aggregating-message-type
+ ((message aggregating-message)
+ (combination (eql :and))
+ (type c-function-type))
+ (check combination c-type-int type)
+ (call-next-method))
+ (defmethod check-aggregating-message-type
+ ((message aggregating-message)
+ (combination (eql :or))
+ (type c-function-type))
+ (check combination c-type-int type)
+ (call-next-method)))
+
+(export 'define-aggregating-method-combination)
+(defmacro define-aggregating-method-combination
+ (comb
+ (vars
+ &key (codegen (gensym "CODEGEN-"))
+ (methods (gensym "METHODS-")))
+ &key properties
+ ((:around around-func) '#'funcall)
+ ((: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.
+
+ 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
+ meth targ func call-methfunc
+ aroundfunc fmethfunc methfunc)
+ `(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))))
+
+ ;; 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)))))
+ ,@(mapcar (lambda (var)
+ (list var `(temporary-var ,codegen ,type)))
+ vars)
+ (,aroundfunc ,around-func)
+ (,methfunc ,methods-func)
+ (,fmethfunc ,(if firstp first-method-func methfunc)))
+
+ ;; Arrange to release the temporaries when we're finished with
+ ;; them.
+ (unwind-protect
+ (progn
+
+ ;; Wrap the AROUND function around most of the work.
+ (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)))))
+
+ ;; 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) `(setf (var-in-use-p ,var) nil))
+ vars))))
+
+ ',comb)))
+
+(define-aggregating-method-combination :progn (nil))
+
+(define-aggregating-method-combination :sum ((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-update-inst acc #\+ val))))
+
+(define-aggregating-method-combination :product ((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-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) nil))))
+
+(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) nil))))
+
+(define-aggregating-method-combination :and ((ret val) :codegen codegen)
+ :around (lambda (body)
+ (codegen-push codegen)
+ (deliver-expr codegen ret 0)
+ (funcall body)
+ (deliver-expr codegen ret 1)
+ (emit-inst codegen
+ (make-do-while-inst (codegen-pop-block codegen) 0)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst (format nil "!~A" val)
+ (make-break-inst) nil))))
+
+(define-aggregating-method-combination :or ((ret val) :codegen codegen)
+ :around (lambda (body)
+ (codegen-push codegen)
+ (deliver-expr codegen ret 1)
+ (funcall body)
+ (deliver-expr codegen ret 0)
+ (emit-inst codegen
+ (make-do-while-inst (codegen-pop-block codegen) 0)))
+ :methods (lambda (invoke)
+ (funcall invoke val)
+ (emit-inst codegen (make-if-inst val (make-break-inst) nil))))
+
+(defmethod aggregating-message-properties
+ ((message aggregating-message) (combination (eql :custom)))
+ '(:retvar :id
+ :valvar :id
+ :decls :fragment
+ :before :fragment
+ :first :fragment
+ :each :fragment
+ :after :fragment))
+
+(defmethod compute-aggregating-message-kernel
+ ((message aggregating-message) (combination (eql :custom))
+ codegen target methods arg-names
+ &key (retvar "sod_ret") (valvar "sod_val")
+ decls before each (first each) after)
+ (let* ((type (c-type-subtype (sod-message-type message)))
+ (not-void-p (not (eq type c-type-void))))
+ (when not-void-p
+ (ensure-var codegen retvar type)
+ (ensure-var codegen valvar type))
+ (when decls
+ (emit-decl codegen decls))
+ (labels ((maybe-emit (fragment)
+ (when fragment (emit-inst codegen fragment)))
+ (invoke (method fragment)
+ (invoke-method codegen (if not-void-p valvar :void)
+ arg-names method)
+ (maybe-emit fragment)))
+ (maybe-emit before)
+ (invoke (car methods) first)
+ (dolist (method (cdr methods)) (invoke method each))
+ (maybe-emit after)
+ (deliver-expr codegen target retvar))))
+
+(export 'standard-effective-method)
+(defclass aggregating-effective-method (simple-effective-method) ()
+ (:documentation "Effective method counterpart to `aggregating-message'."))
+
+(defmethod 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 (message-kernel-function (effective-method-message method))
+ codegen target argument-names primary-methods)))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff