[cmucl-imp] Unboxed float arguments
Marco Antoniotti
marcoxa at cs.nyu.edu
Sun Jun 10 06:39:21 UTC 2012
Cool.
I have not really looked at the code, but how generalizable would this approach be? I.e. why stop at FTYPEd floats?
I am asking because of Pascal Costanza's recent post on the PRO mailing list about stack-allocation of values (a DYNAMIC-EXTENT on steroids)
Cheers
--
Marco
On Jun 9, 2012, at 09:46 , Helmut Eller wrote:
> Here is an idea for a calling convention that supports unboxed floats:
>
> 1. When DEFUN compiles a function that has a ftype declaration involving
> floats, it creates a special entry-point that accepts unboxed arguments.
>
> 2. Named calls to such functions are compiled so that the arguments are
> represented as indicated by the ftype declaration.
>
> 3. We also keep a linker table to connect those special entry-points to
> call-sites. When the function gets redefined, we go through the
> existing call-sites and patch them so that the new definition is called.
> If the type of the new definition is different than the one expected by
> the call-site, we create an "adapter function" that converts the
> representation to the new type or if the conversion is not possible
> signals an error.
>
> Attached is a prototype implementation to illustrate how this could be
> done. See the comments in the file for the main points. A more
> polished implementation would probably change more places then
> MAKE-XEP-LAMBDA.
>
> What do you think: is such a calling convention worth having?
>
> Helmut
>
>
> ;; Toy implementation for a calling convention with unboxed arguments.
>
> (in-package cl-user)
>
> ;; Conceptionally we'd like to create functions that have two entry
> ;; points: one that accepts only arguments of a specific
> ;; type/representation and a general entry point that accept all
> ;; possible types as a fallback.
> ;;
> ;; A "typed entry point" is an entry point that only accepts arguments
> ;; of that specfic type and makes no typechecks. There is a direct
> ;; mapping from the function's type to the representation of the
> ;; arguments and return values. So if we know the type, e.g. from a
> ;; ftype declaration, we can predict the representation.
> ;;
> ;; This implementation actually uses two functions instead of one
> ;; function with two entry points.
>
> ;; We use function names like (:typed-entry-point foo) for functions
> ;; which have a typed entry point.
> (ext:define-function-name-syntax :typed-entry-point (name)
> (ext:valid-function-name-p (cadr name)))
>
> ;; A callsite describes what we need to know to link/re-link a call to
> ;; a typed entry point. The TYPE slot is the type of the callsite. We
> ;; use FDEFN to call the entry. In theory, we could patch the call
> ;; instruction with the correct address of the entry point, but code
> ;; patching is always tricky, so for now we use an indirection through
> ;; fdefn objects and only patch the address in the fdefn.
> ;;
> ;; When a function gets redefined we patch existing callsites so that
> ;; the new function gets called. We record the type of the callsite
> ;; so that we can verify that the type of the new definition matches
> ;; existing callsites. If the types match, we simply patch the fdefn
> ;; and are done. If the types don't match we generate an "adapter
> ;; function". The job of an adapter is it to take arguments of some
> ;; particular type and box/unbox them so that it becomes possible to
> ;; call the new definition. The current adapter implementation would
> ;; sometimes create endless recursions, so we have and ADAPT flag to
> ;; disable the creation of adapters for some callsites.
> ;;
> (defstruct callsite
> (type (ext:required-argument) :type kernel:function-type :read-only t)
> (fdefn (ext:required-argument) :type kernel:fdefn :read-only t)
> (adapt (ext:required-argument) :type boolean :read-only t))
>
> (defstruct linkage
> (callsites nil :type (or callsite list))
> (adapters nil :type (or function list)))
>
> ;; For functions with typed entry points we maintiain a list of
> ;; callsites and record that in the info db.
> ;;
> ;; If we use typed entry points only for functions with ftype
> ;; declarations then this table is probably relatively small.
> (ext:define-info-type function linkage linkage)
>
> (defun listify (x)
> (if (listp x) x (list x)))
>
> (defmacro push-unlistified (new-value (reader object))
> `(let ((new-value ,new-value) (object ,object))
> (let ((old-value (,reader ,object)))
> (setf (,reader object)
> (typecase old-value
> (null new-value)
> (cons (cons new-value old-value))
> (t (list new-value old-value)))))))
>
> ;; find-typed-entry-point is called at load-time and returns the
> ;; fdefn that should be called.
> ;;
> ;; 1. We go through the list of existing callsites to see if we
> ;; already have one with the same type and reuse it if possible.
> ;;
> ;; 2. We look at the current definition. If the types match, we
> ;; create a callsite object, store it in the info db, and return the
> ;; fdefn.
> ;;
> ;; 3. Now we know that the types don't match we need to use adapters.
> ;; First again, we look at existing adapters and reuse them if possible.
> ;;
> ;; 4. An adapter is created that boxes the arguments and forwards the
> ;; call to the "normal" entry point.
> ;;
> ;; 5. If we are not allowed to create adapters, we look again at the
> ;; current definition to handle the case where no current definition
> ;; exists. If so, we return an empty fdefn object that will call the
> ;; undefined-tramp assembly routine.
> ;;
> ;; 6. If all else fails we link the callsite to our error handler.
> ;;
> (declaim (ftype (function (t t boolean) kernel:fdefn) find-typed-entry-point))
> (defun find-typed-entry-point (name callsite-typespec adapt)
> (let* ((cs-type (kernel:specifier-type callsite-typespec))
> (linkage (multiple-value-bind (info foundp)
> (ext:info function linkage name)
> (cond (foundp info)
> (t (setf (ext:info function linkage name)
> (make-linkage)))))))
> (cond ((dolist (cs (listify (linkage-callsites linkage)))
> (let* ((ep-type (callsite-type cs)))
> (when (and (function-types-compatible-p cs-type ep-type)
> (eq (callsite-adapt cs) adapt))
> (return (callsite-fdefn cs))))))
> ((let ((fdefn (lisp::fdefinition-object name nil)))
> (when fdefn
> (let ((fun (kernel:fdefn-function fdefn)))
> (when fun
> (let ((ep-type (kernel:extract-function-type fun)))
> (when (function-types-compatible-p cs-type ep-type)
> (let* ((aname (kernel:%function-name fun))
> (fdefn (kernel:make-fdefn aname))
> (cs (make-callsite :type cs-type :fdefn fdefn
> :adapt adapt)))
> (setf (kernel:fdefn-function fdefn) fun)
> (push-unlistified cs (linkage-callsites linkage))
> fdefn))))))))
> ((and adapt
> (dolist (fun (listify (linkage-adapters linkage)))
> (let ((ep-type (kernel:extract-function-type fun)))
> (when (function-types-compatible-p cs-type ep-type)
> (let* ((aname (kernel:%function-name fun))
> (fdefn (kernel:make-fdefn aname))
> (cs (make-callsite :type cs-type :fdefn fdefn
> :adapt adapt)))
> (setf (kernel:fdefn-function fdefn) fun)
> (push-unlistified cs (linkage-callsites linkage))
> (return fdefn)))))))
> ((and adapt
> (let* ((fun (generate-adapter-function cs-type (second name)))
> (fdefn (kernel:make-fdefn (kernel:%function-name fun)))
> (cs (make-callsite :type cs-type :fdefn fdefn
> :adapt adapt)))
> (setf (kernel:fdefn-function fdefn) fun)
> (push-unlistified fun (linkage-adapters linkage))
> (push-unlistified cs (linkage-callsites linkage))
> fdefn)))
> ((and (not adapt)
> (or (not (lisp::fdefinition-object name nil))
> (not (kernel:fdefn-function
> (lisp::fdefinition-object name nil)))))
> (let* ((aname `(:typed-entry-point #:undefined))
> (fdefn (kernel:make-fdefn aname))
> (cs (make-callsite :type cs-type :fdefn fdefn :adapt adapt)))
> (push-unlistified cs (linkage-callsites linkage))
> fdefn))
> (t
> (let* ((fun (generate-adapter-function cs-type 'linkage-error))
> (fdefn (kernel:make-fdefn (kernel:%function-name fun)))
> (cs (make-callsite :type cs-type :fdefn fdefn :adapt adapt)))
> (setf (kernel:fdefn-function fdefn) fun)
> (push-unlistified cs (linkage-callsites linkage))
> fdefn)))))
>
> (defun linkage-error (&rest args)
> (declare (ignore args))
> (error "Linking callsite to typed-entry-point failed"))
>
> ;; Generate an adapter function that changes the representation of the
> ;; arguments (specified with FTYPE) and forwards the call to NAME.
> ;; The adapter has also a typed entry point. It should also check
> ;; that the values returned by NAME match FTYPE.
> ;;
> ;; In practice, the compiler infered type may not match exactly FTYPE,
> ;; even if we add lotso declarations. This is annyoingly brittle.
> (defun generate-adapter-function (ftype name)
> (let* ((atypes (kernel:function-type-required ftype))
> (tmps (loop for nil in atypes collect (gensym)))
> (fname `(:typed-entry-point
> :boxing-adapter ,(make-symbol (string name))))
> (ftypespec (kernel:type-specifier ftype)))
> (proclaim `(ftype ,ftypespec ,fname))
> (compile fname
> `(lambda ,tmps
> (declare
> ,@(loop for tmp in tmps
> for type in atypes
> collect `(type ,(kernel:type-specifier type) ,tmp)))
> (the ,(kernel:type-specifier
> (kernel:function-type-returns ftype))
> (funcall (function ,name) . ,tmps))))
> (let ((fun (fdefinition fname)))
> (unless (eq name 'linkage-error)
> (fix-ftype fun ftype))
> fun)))
>
> (defun fix-ftype (fun ftype)
> (let ((etype (kernel:extract-function-type fun)))
> (unless (function-types-compatible-p ftype etype t)
> (break)))
> fun)
>
> ;; This is our rule to decide when a type at a callsite matches the
> ;; type of the entry point.
> ;;
> ;; 1. The arguments at the callsite should be subtypes of the
> ;; arguments at the entry point.
> ;;
> ;; 2. The return value at the callsite should be supertypes of the
> ;; return values at the entry point.
> ;;
> ;; 3. The representations must agree. Representations should probably
> ;; decided in the backend, but for now we assume only double-floats
> ;; are unboxed.
> (defun function-types-compatible-p (callsite-type entrypoint-type
> &optional ignore-representation)
> (flet ((return-types (ftype)
> (let ((type (kernel:function-type-returns ftype)))
> (cond ((kernel:values-type-p type)
> (assert (and (not (kernel:values-type-rest type))
> (not (kernel:values-type-keyp type))))
> (kernel:values-type-required type))
> (t
> (list type)))))
> (ptype= (type1 type2)
> (let ((double-float (kernel:specifier-type 'double-float)))
> (cond (ignore-representation t)
> ((kernel:type= type1 double-float)
> (kernel:type= type2 double-float))
> ((kernel:type= type2 double-float)
> nil)
> (t t)))))
> (and (every #'kernel:csubtypep
> (kernel:function-type-required callsite-type)
> (kernel:function-type-required entrypoint-type))
> (every #'ptype=
> (kernel:function-type-required callsite-type)
> (kernel:function-type-required entrypoint-type))
> (or
> (and (every #'kernel:csubtypep
> (return-types entrypoint-type)
> (return-types callsite-type))
> (every #'ptype=
> (return-types entrypoint-type)
> (return-types callsite-type)))
> (kernel:type= (kernel:function-type-returns entrypoint-type)
> (kernel:specifier-type 'nil))))))
>
>
> ;; check-function-redefinition is used as setf-fdefinition-hook.
> ;; We go through all existing callsites and
> ;;
> ;; 1. If the new type matches, we patch the callsite with the new function.
> ;;
> ;; 2. If the types don't match and if allowed, we redirect the
> ;; callsite to and adapter.
> ;;
> ;; 3. If the callsites doesn't want adapters we link the callsite to
> ;; an error handler.
> (defun check-function-redefinition (name new-fun)
> (when (and (consp name)
> (eq (car name) :typed-entry-point)
> (not (eq (cadr name) :boxing-adapter)))
> (multiple-value-bind (linkage foundp) (ext:info function linkage name)
> (when foundp
> (let ((new-type (kernel:extract-function-type new-fun)))
> (dolist (cs (listify (linkage-callsites linkage)))
> (let ((cs-type (callsite-type cs))
> (fdefn (callsite-fdefn cs)))
> (cond ((function-types-compatible-p cs-type new-type)
> (patch-fdefn fdefn new-fun))
> ((and
> (callsite-adapt cs)
> (dolist (fun (listify (linkage-adapters linkage)))
> (let ((ep-type (kernel:extract-function-type fun)))
> (when (function-types-compatible-p cs-type ep-type)
> (patch-fdefn fdefn fun)
> (return t))))))
> ((callsite-adapt cs)
> (let ((fun (generate-adapter-function
> cs-type (second name))))
> (push-unlistified fun (linkage-adapters linkage))
> (patch-fdefn fdefn fun)))
> (t
> (format nil "~3t")
> (warn "New type of ~s incompatible with callsite:~%~
> ~2t new-type: ~s~%~
> ~2t cs-type: ~s" name
> (kernel:type-specifier new-type)
> (kernel:type-specifier cs-type))
> (let ((fun (generate-adapter-function
> cs-type 'linkage-error)))
> (patch-fdefn fdefn fun)))))))))))
>
> ;; This lets us set the name in fdefn objects. We use that for
> ;; debugging.
> (eval-when (:compile-toplevel)
> (c:defknown set-fdefn-name (kernel:fdefn t) t)
> (c:def-setter set-fdefn-name vm:fdefn-name-slot vm:other-pointer-type))
>
> (defun patch-fdefn (fdefn new-fun)
> (setf (kernel:fdefn-function fdefn) new-fun)
> (let ((name (kernel:%function-name new-fun)))
> (set-fdefn-name fdefn name))
> fdefn)
>
> (pushnew 'check-function-redefinition ext:*setf-fdefinition-hook*)
>
> (in-package x86)
>
> ;; make-typed-call-tns chooses the representation for a function type.
> ;; This is similar to c::make-call-out-tns and should probably also be
> ;; a vm-support-routine.
> ;;
> ;; The current convention passes double-floats unboxed and all other
> ;; types remain boxed. Registers XMM4-XMM7 are used for the first 4
> ;; double arguments. Boxed values are passed in standard locations.
> ;;
> ;; Returning values on the stack is currenlty not implemented, so all
> ;; return values must fit in registers.
> (defun make-typed-call-tns (ftype)
> (declare (type function-type ftype))
> (labels ((ptype (name) (primitive-type-or-lose name *backend*))
> (double-float-arg (state)
> (cond ((<= (getf state :xmms-reg) xmm7-offset)
> (make-wired-tn (ptype 'double-float)
> double-reg-sc-number
> (prog1 (getf state :xmms-reg)
> (incf (getf state :xmms-reg)))))
> (t
> (make-wired-tn (ptype 'double-float)
> double-stack-sc-number
> (prog1 (getf state :frame-size)
> (incf (getf state :frame-size) 2))))))
> (boxed-arg (state)
> (cond ((<= (getf state :reg-args) register-arg-count)
> (let ((n (getf state :reg-args)))
> (incf (getf state :reg-args))
> (x86-standard-argument-location n)))
> (t
> (make-wired-tn (ptype 't)
> control-stack-sc-number
> (prog1 (getf state :frame-size)
> (incf (getf state :frame-size) 1))))))
> (double-float-type-p (type)
> (and (numeric-type-p type)
> (eq (numeric-type-class type) 'float)
> (eq (numeric-type-format type) 'double-float)))
> (arg-tn (type state)
> (cond ((double-float-type-p type) (double-float-arg state))
> (t (boxed-arg state))))
> (ret-tn (type state)
> (let ((tn (arg-tn type state)))
> (assert (member (sc-name (tn-sc tn))
> '(double-reg descriptor-reg)))
> tn)))
> (let* ((arg-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0))
> (ret-state (list :frame-size 2 :xmms-reg xmm4-offset :reg-args 0))
> (returns (function-type-returns ftype))
> (rtypes (typecase returns
> (values-type (values-type-required returns))
> (t (list returns)))))
> (values
> (loop for type in (function-type-required ftype)
> collect (arg-tn type arg-state))
> (loop for type in rtypes
> collect (ret-tn type ret-state))
> (x86-make-stack-pointer-tn)
> (max (getf arg-state :frame-size)
> (getf ret-state :frame-size))
> (x86-make-number-stack-pointer-tn)
> 0))))
>
> ;; This VOP performs the call. Note the (:move-args :local-call)
> ;; which, hopefully, coerces and moves arguments to the correct
> ;; representation.
> (define-vop (cl-user::call-typed-named)
> (:args (new-fp)
> (new-nfp)
> (fdefn :scs (descriptor-reg control-stack)
> :target eax)
> (args :more t :scs (descriptor-reg)))
> (:results (results :more t))
> (:save-p t)
> (:move-args :local-call)
> (:vop-var vop)
> (:info arg-locs real-frame-size)
> (:ignore new-nfp args arg-locs results)
> (:temporary (:sc descriptor-reg :offset eax-offset)
> eax)
> (:generator 30
> ;; FIXME: allocate the real frame size here. We had to emit
> ;; ALLOCATE-FRAME before this vop so that we can use the
> ;; (:move-args :local-call) option here. Without the
> ;; ALLOCATE-FRAME vop we get a failed assertion.
> (inst lea esp-tn (make-ea :dword :base new-fp
> :disp (- (* real-frame-size word-bytes))))
>
> ;; Move fdefn to eax before switching frames.
> (move eax fdefn)
>
> ;; Write old frame pointer (epb) into new frame.
> (storew ebp-tn new-fp (- (1+ ocfp-save-offset)))
>
> ;; Switch to new frame.
> (move ebp-tn new-fp)
>
> (note-this-location vop :call-site)
>
> ;; Load address out of fdefn and call it.
> (inst call (make-ea :dword :base eax
> :disp (- (* fdefn-raw-addr-slot word-bytes)
> other-pointer-type)))
>
> ))
>
> (in-package c)
>
> ;; To generate typed entry points we modify MAKE-XEP-LAMBDA.
> ;; Currently we use the function name as marker: if the name looks
> ;; like (:typed-entry-point <foo>) then we know we need to our thing.
> ;;
> ;; We lookup the currently declared type and create wrap code around
> ;; the main function. Our code receives and returns the values with
> ;; typed calling convention. The n-supplied argument is not used, but
> ;; the rest of the compiler want it to be there (generates no code
> ;; thogh).
> ;;
> ;; FIXME: instead of using the function name as marker it might be
> ;; better to have a declaration to request typed entry points.
> ;;
> ;; FIXME: %return-results-with-type is currently not inlined
> ;; (let-converted) proberly and instead generates local-call. Getting
> ;; the optimisations correctly dones also seems rather brittle.
> (fwrappers:define-fwrapper make-xep-lambda-wrapper (fun)
> (declare (type functional fun))
> (cond ((and (consp (functional-name fun))
> (eq (car (functional-name fun))
> :typed-entry-point))
> (let* ((ftype (the function-type
> (info function type (functional-name fun))))
> (fspec (type-specifier ftype))
> (returns (function-type-returns ftype))
> (rtypes (typecase returns
> (values-type (values-type-required returns))
> (t (list returns))))
> (n-supplied (gensym))
> (temps (loop for nil in (lambda-vars fun) collect (gensym)))
> (results (loop for nil in rtypes collect (gensym))))
> `(lambda (,n-supplied)
> (declare (ignore ,n-supplied))
> (multiple-value-bind ,temps
> (cl-user::%receive-arguments-with-type ',fspec)
> (multiple-value-bind ,results
> (the ,(type-specifier returns)
> (%funcall ,fun . ,temps))
> (cl-user::%return-results-with-type
> ',fspec . ,results))))))
> (t
> (fwrappers:call-next-function))))
>
> (fwrappers:fwrap 'make-xep-lambda 'make-xep-lambda-wrapper)
>
>
> ;; %receive-arguments-with-type knows how to access the arguments from
> ;; the passing locations.
> (defknown cl-user::%receive-arguments-with-type (cons) *)
>
> (defoptimizer (cl-user::%receive-arguments-with-type derive-type) ((ftypespec))
> (unless (constant-continuation-p ftypespec)
> (error "Function-type must be constant."))
> (let ((ftype (the function-type
> (specifier-type (continuation-value ftypespec)))))
> (values-specifier-type
> `(values . ,(mapcar #'type-specifier (function-type-required ftype))))))
>
> ;; Here we generate the IR2 to receive arguments. make-typed-call-tns
> ;; chooses the representation and move-continuation-result does the
> ;; rest.
> (defoptimizer (cl-user::%receive-arguments-with-type ir2-convert)
> ((ftypespec) node block)
> (let* ((ftype (the function-type
> (specifier-type (continuation-value ftypespec))))
> (cont (node-cont node))
> (arg-tns (x86::make-typed-call-tns ftype)))
> (move-continuation-result node block arg-tns cont)))
>
> (defknown cl-user::%return-results-with-type (cons &rest *) nil)
>
> (defoptimizer (cl-user::%return-results-with-type ltn-annotate)
> ((type &rest args) node policy)
> (dolist (arg args)
> (annotate-ordinary-continuation arg policy)))
>
> ;; %return-results-with-type is similar to a known-return just that we
> ;; let make-typed-call-tns choose the representation.
> (defoptimizer (cl-user::%return-results-with-type ir2-convert)
> ((type &rest args) node block)
> (let* ((ftype (the function-type
> (specifier-type (continuation-value type))))
> (home (lambda-home (lexenv-lambda (node-lexenv node))))
> (env (environment-info (lambda-environment home)))
> (old-fp (ir2-environment-old-fp env))
> (return-pc (ir2-environment-return-pc env)))
> (multiple-value-bind (arg-tns result-tns) (x86::make-typed-call-tns ftype)
> (declare (ignore arg-tns))
> (let ((val-tns (loop for arg in args
> collect (continuation-tn node block arg))))
> (vop* known-return node block
> (old-fp return-pc (reference-tn-list val-tns nil))
> (nil)
> result-tns)))))
>
> (defknown cl-user::%typed-call (cons &rest *) *)
>
> ;; %typed-call gets transformed to %%typed-call. We create the the
> ;; load-time-value-form and some type declarations.
> ;;
> ;; FIXME: The :adapt option should probably be a separate argument,
> ;; but for now it's encoded in the function name.
> ;;
> ;; FIXME: why is the truly-the still needed? Shouldn't
> ;; load-time-value be able use the declared return type of
> ;; find-typed-entry-point?
> (deftransform cl-user::%typed-call ((name &rest args)
> * * :important t)
> (unless (constant-continuation-p name)
> (error "Function name must be constant."))
> (destructuring-bind (&key typed-entry-point adapt) (continuation-value name)
> (let* ((name typed-entry-point)
> (ftype (the function-type
> (info function type `(:typed-entry-point ,name))))
> (vars (loop for nil in (function-type-required ftype)
> collect (gensym))))
> `(lambda (name , at vars)
> (declare (ignore name)
> ,@(loop for type in (function-type-required ftype)
> for var in vars
> collect `(type ,(type-specifier type) ,var)))
> (cl-user::%%typed-call
> (locally (declare (optimize speed))
> (truly-the fdefn
> (load-time-value (cl-user::find-typed-entry-point
> '(:typed-entry-point ,name)
> ',(type-specifier ftype)
> ',adapt)
> t)))
> ',ftype , at vars)))))
>
> (defknown cl-user::%%typed-call (fdefn function-type &rest *) *)
>
> (defoptimizer (cl-user::%%typed-call derive-type) ((fdefn type &rest args))
> (let ((ftype (continuation-value type)))
> (function-type-returns ftype)))
>
> (defoptimizer (cl-user::%%typed-call ltn-annotate)
> ((fdefn type &rest args) node policy)
> (setf (basic-combination-info node) :funny)
> (setf (node-tail-p node) nil)
> (annotate-ordinary-continuation fdefn policy)
> (dolist (arg args)
> (annotate-ordinary-continuation arg policy)))
>
> ;; A typed-call we is similar to a known-local-call.
> ;; make-typed-call-tns chooses the argument representation.
> ;;
> ;; 1. allocate a frame
> ;; 2. moving/coercing the arguments and done the CALL-TYPED-NAMED vop
> ;; 3. move-continuation-result moves the results in the right place
> ;;
> ;; FIXME: all return values are in registers move-continuation-result
> ;; can probably not handle stack arguments.
> ;;
> ;; FIXME: the ALLOCATE-FRAME vop isn't quite right for us, see the
> ;; comment in call-typed-named.
> ;;
> ;; FIXME: currently can't make tail calls. We would need to guarantee
> ;; that the types match.
> (defoptimizer (cl-user::%%typed-call ir2-convert)
> ((fdefn type &rest args) node block)
> (let ((ftype (the function-type (continuation-value type)))
> (cont (node-cont node)))
> (multiple-value-bind (arg-tns result-tns
> fp stack-frame-size
> nfp number-stack-frame-size)
> (x86::make-typed-call-tns ftype)
> (declare (ignore number-stack-frame-size))
> (let ((fdefn-tn (continuation-tn node block fdefn))
> (cont-tns (loop for arg in args
> collect (continuation-tn node block arg))))
> (vop allocate-frame node block nil fp nfp)
> (vop* cl-user::call-typed-named node block
> (fp nfp fdefn-tn (reference-tn-list cont-tns nil))
> ((reference-tn-list result-tns t))
> arg-tns stack-frame-size)
> (move-continuation-result node block result-tns cont)))))
> ;; Tests for typed calling convention.
>
> (in-package :cl-user)
>
> (eval-when (:compile-toplevel)
> (fmakunbound '(:typed-entry-point fid))
> (fmakunbound '(:typed-entry-point sum-prod))
> (fmakunbound '(:typed-entry-point cons-sum))
> (fmakunbound '(:typed-entry-point id)))
>
> ;; First we create a declaration
> (declaim (ftype (function (double-float) double-float)
> (:typed-entry-point fid)))
>
> ;; then the typed entry point
> (defun (:typed-entry-point fid) (f) f)
>
> ;; then the "normal" entry point, which calls the typed version.
> (defun fid (f)
> (%typed-call '(:typed-entry-point fid :adapt nil) f))
>
> ;; and also a compiler macro so that named calls automtomatically call
> ;; the typed entry point.
> (define-compiler-macro fid (f)
> `(%typed-call '(:typed-entry-point fid :adapt t) ,f))
>
> (defun test-fid-1 ()
> (assert (= (fid 1d0) 1d0)))
>
> ;; (fid 1d0)
> ;; (disassemble '(:typed-entry-point fid))
> ;; (disassemble 'fid)
>
> ;; Let's wrap that up as macro. In a more polished implementation
> ;; DEFUN could do all this.
> (defmacro defun-typed (name (&rest args) ((&rest arg-types) return-type)
> &body body)
> `(progn
> (declaim (ftype (function ,arg-types ,return-type)
> (:typed-entry-point ,name)))
> (defun (:typed-entry-point ,name) ,args
> (the ,return-type
> . ,body))
> (defun ,name ,args
> (%typed-call '(:typed-entry-point ,name :adapt nil) . ,args))
> (define-compiler-macro ,name ,args
> `(%typed-call '(:typed-entry-point ,',name :adapt t)
> . ,(list . ,args)))))
>
> (defun-typed f+ (x y)
> ((double-float double-float) double-float)
> (+ x y))
>
> ;; (disassemble '(:typed-entry-point f+))
>
> (defun-typed sum-prod (x y z u v w)
> ((double-float double-float double-float
> double-float double-float double-float)
> (values double-float double-float))
> (values (+ x y z u v w)
> (* x y z u v w)))
>
> ;; (disassemble '(:typed-entry-point sum-prod))
> ;; (ext:info function linkage '(:typed-entry-point sum-prod))
>
> (defun test-sum-prod-1 ()
> (multiple-value-bind (sum prod) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0)
> (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0)))
> (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0)))))
>
> (defun test-sum-prod-2 ()
> (multiple-value-bind (sum) (sum-prod 2d0 3d0 4d0 5d0 6d0 7d0)
> (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0)))))
>
> (defun test-sum-prod-3-aux (x y z u v w)
> (sum-prod x y z u v w))
>
> (defun test-sum-prod-3 ()
> (multiple-value-bind (sum prod) (test-sum-prod-3-aux 2d0 3d0 4d0 5d0 6d0 7d0)
> (assert (= sum (+ 2d0 3d0 4d0 5d0 6d0 7d0)))
> (assert (= prod (* 2d0 3d0 4d0 5d0 6d0 7d0)))))
>
> (defun-typed id (x)
> ((t) t)
> x)
>
> ;; (id 1)
>
> (defun test-id-1 ()
> (assert (eql (id 1) 1)))
>
> (defun test-id-2 ()
> (assert (eql (id 1d0) 1d0)))
>
> ;; This one has both boxed and unboxed arguments.
> (defun-typed cons-sum (o1 f1 o2 f2)
> ((t double-float t double-float)
> (values cons double-float))
> (values (cons o1 o2) (+ f1 f2)))
>
> (defun test-cons-sum-1 ()
> (multiple-value-bind (cons sum) (cons-sum 1 2d0 3 4d0)
> (assert (equal cons '(1 . 3)))
> (assert (= sum (+ 2d0 4d0)))))
>
> ;; SUM will be redefined with different types to exercise the linker a
> ;; bit.
> (defun-typed sum (f1 f2)
> ((double-float double-float) double-float)
> (+ f1 f2))
>
> (defun test-sum-1 ()
> (assert (= (sum 2d0 3d0) 5d0)))
>
> (defun-typed sum (f1 f2)
> ((t t) t)
> (+ f1 f2))
>
> (defun test-sum-2 ()
> (assert (= (sum 2d0 3d0) 5d0)))
>
> (defun test-sum-3 ()
> (handler-case (progn (sum 2 3)
> (assert nil))
> (type-error (c)
> (assert (equal (type-error-datum c) 3))
> (assert (eq (type-error-expected-type c) 'double-float)))))
>
> (defun-typed sum (f1 f2)
> ((t double-float) double-float)
> (+ f1 f2))
>
> (defun test-sum-4 ()
> (assert (= (sum 2d0 3d0) 5d0)))
>
> (defun test-sum-5 ()
> (assert (= (sum 2 3d0) 5d0)))
>
> (defun test-sum-6 ()
> (handler-case (progn
> (sum #c(0 1) 3d0)
> (assert nil))
> (type-error (c)
> (assert (equal (type-error-datum c) #c(3d0 1d0)))
> (assert (eq (type-error-expected-type c) 'double-float)))))
>
> #+(or)
> (defun foo ()
> (labels ((sum (x y) (+ x y)))
> (declare (ftype (function (double-float double-float) double-float) sum))
> (list (sum 2d0 4d0)
> (sum 2 4))))
>
> (defun tests ()
> (test-fid-1)
> (test-sum-prod-1)
> (test-sum-prod-2)
> (test-sum-prod-3)
> (test-id-1)
> (test-id-2)
> (test-cons-sum-1)
> (test-sum-1)
> (test-sum-2)
> (test-sum-3)
> (test-sum-4)
> (test-sum-5)
> (test-sum-6)
> )
>
> ;; (tests)
> _______________________________________________
> cmucl-imp mailing list
> cmucl-imp at cmucl.cons.org
> http://lists.zs64.net/mailman/listinfo/cmucl-imp
--
Marco Antoniotti
More information about the cmucl-imp
mailing list