Unboxed float arguments

;; 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)