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)
