June 2012 - cmucl-imp - mailman3.common-lisp.net

[cmucl-imp] Unboxed float arguments
by Helmut Eller 30 Jun '12

30 Jun '12

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)

3 12

[cmucl-imp] New branches
by Raymond Toy 29 Jun '12

29 Jun '12

FYI, I pushed up a couple of new branches. The branch file-attribute contains Douglas' contribution which adds a new external format called :file-attribute that will determines the actual external format to use by looking for an emacs -*- mode line near the beginning of the file. The encoding is determined by looking for "encoding: <encoding>;" and <encoding> is used for the external-format. The other branch is tcall-convention for Helmut's tcall-convention patch for calling functions with unboxed arguments. Ray

1 0

[cmucl-imp] Snapshot 2012-06
by Raymond Toy 13 Jun '12

13 Jun '12

The 2012-06 snapshot has been tagged. Binaries will be uploaded soon. Ray

1 0