(: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.
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.
(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.
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.
(with-gensyms (type msg combvar target arg-names args want-type
meth targ func call-methfunc
- aroundfunc fmethfunc methfunc)
+ aroundfunc fmethfunc methfunc bodyfunc)
`(progn
;; If properties are listed, arrange for them to be collected.
,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))
;; 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)))))
+ `((,type (c-type-subtype (sod-message-type ,msg)))
+ (,(car vars) (temporary-var ,codegen ,type))))
,@(mapcar (lambda (var)
- (list var `(temporary-var ,codegen ,type)))
- vars)
+ (list var `(and ,methods
+ (temporary-var ,codegen ,type))))
+ (cdr 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)))))
+ (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) `(setf (var-in-use-p ,var) nil))
- 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)
+ :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)))
(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-if-inst (format nil "~A > ~A" acc val)
- (make-set-inst acc val) nil))))
+ (make-set-inst acc val)))))
(define-aggregating-method-combination :max ((acc val) :codegen codegen)
:first-method (lambda (invoke)
:methods (lambda (invoke)
(funcall invoke val)
(emit-inst codegen (make-if-inst (format nil "~A < ~A" acc val)
- (make-set-inst acc val) nil))))
+ (make-set-inst acc val)))))
-(define-aggregating-method-combination :and ((ret val) :codegen codegen)
- :return-type int
+(define-aggregating-method-combination :and ((ret) :codegen codegen)
+ :empty (lambda () (emit-inst codegen (make-set-inst ret 1)))
: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))))
+ (funcall invoke ret)
+ (emit-inst codegen (make-if-inst (format nil "!~A" ret)
+ (make-break-inst)))))
-(define-aggregating-method-combination :or ((ret val) :codegen codegen)
- :return-type int
+(define-aggregating-method-combination :or ((ret) :codegen codegen)
+ :empty (lambda () (emit-inst codegen (make-set-inst ret 0)))
: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))))
+ (funcall invoke ret)
+ (emit-inst codegen (make-if-inst ret (make-break-inst)))))
;;;--------------------------------------------------------------------------
;;; A customizable aggregating method combination.
((message aggregating-message) (combination (eql :custom)))
'(:retvar :id
:valvar :id
+ :methty :type
+ :empty :fragment
:decls :fragment
:before :fragment
:first :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")
- decls before each (first each) after count)
+ &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)))
- (not-void-p (not (eq type c-type-void))))
- (when not-void-p
- (ensure-var codegen retvar type)
- (ensure-var codegen valvar type))
- (when count
+ (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 decls
+ (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 not-void-p valvar :void)
+ (invoke-method codegen
+ (if (eq methty c-type-void) :void valvar)
arg-names method)
(maybe-emit fragment)))
- (maybe-emit before)
- (invoke (car methods) first)
- (dolist (method (cdr methods)) (invoke method each))
- (maybe-emit after)
+ (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 --------------------------------------------------
~mdw / sod / blobdiff