Re: Unboxed float arguments

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 ,@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 ,@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
> [email protected]
> http://lists.zs64.net/mailman/listinfo/cmucl-imp

--
Marco Antoniotti


_______________________________________________
cmucl-imp mailing list
[email protected]
http://lists.zs64.net/mailman/listinfo/cmucl-imp