Index: /branches/working-0711/ccl/compiler/X86/X8632/x8632-backend.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/X8632/x8632-backend.lisp (revision 12693) +++ /branches/working-0711/ccl/compiler/X86/X8632/x8632-backend.lisp (revision 12694) @@ -383,6 +383,6 @@ (defun x8632::generate-callback-bindings (stack-ptr fp-args-ptr argvars - argspecs result-spec - struct-result-name) + argspecs result-spec + struct-result-name) (declare (ignore fp-args-ptr)) (collect ((lets) @@ -409,28 +409,27 @@ (double nil)) (if (typep argtype 'foreign-record-type) - (lets (list name - `(%inc-ptr ,stack-ptr - ,(prog1 offset - (incf offset - (* 4 (ceiling bits 32))))))) - (progn - (lets (list name - `(, - (ecase (foreign-type-to-representation-type argtype) - (:single-float '%get-single-float) - (:double-float (setq double t) '%get-double-float) - (:signed-doubleword (setq double t) - '%%get-signed-longlong) - (:signed-fullword '%get-signed-long) - (:signed-halfword '%get-signed-word) - (:signed-byte '%get-signed-byte) - (:unsigned-doubleword (setq double t) - '%%get-unsigned-longlong) - (:unsigned-fullword '%get-unsigned-long) - (:unsigned-halfword '%get-unsigned-word) - (:unsigned-byte '%get-unsigned-byte) - (:address '%get-ptr)) - ,stack-ptr - ,offset))) + (let* ((form `(%inc-ptr ,stack-ptr + ,(prog1 offset + (incf offset + (* 4 (ceiling bits 32))))))) + (when name (lets (list name form)))) + (let* ((form `(, + (ecase (foreign-type-to-representation-type argtype) + (:single-float '%get-single-float) + (:double-float (setq double t) '%get-double-float) + (:signed-doubleword (setq double t) + '%%get-signed-longlong) + (:signed-fullword '%get-signed-long) + (:signed-halfword '%get-signed-word) + (:signed-byte '%get-signed-byte) + (:unsigned-doubleword (setq double t) + '%%get-unsigned-longlong) + (:unsigned-fullword '%get-unsigned-long) + (:unsigned-halfword '%get-unsigned-word) + (:unsigned-byte '%get-unsigned-byte) + (:address '%get-ptr)) + ,stack-ptr + ,offset))) + (when name (lets (list name form))) (incf offset 4) (when double (incf offset 4))))))))) Index: /branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp (revision 12693) +++ /branches/working-0711/ccl/compiler/X86/X8664/x8664-backend.lisp (revision 12694) @@ -88,5 +88,6 @@ :target-arch x8664::*x8664-target-arch* ;; Overload %gs until Apple straightens things out. - :lisp-context-register x8664::gs + ;; Whoops; they never did. + :lisp-context-register x8664::r11 )) @@ -590,34 +591,37 @@ (:float (if (< (decf fprs) 0) (setq first8 :memory))))) (if (eq first8 :memory) + (let* ((form `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset + (incf memory-arg-offset (* 8 (ceiling bits 64))))))) + (when name + (lets (list name form)) + (dynamic-extent-names name))) (progn - (lets (list name `(%inc-ptr ,stack-ptr ,(prog1 memory-arg-offset - (incf memory-arg-offset (* 8 (ceiling bits 64))))))) - (dynamic-extent-names name)) - (progn - (rlets (list name (foreign-record-type-name argtype))) - (inits `(setf (%%get-unsigned-longlong ,name 0) - (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr))))) + (when name (rlets (list name (foreign-record-type-name argtype)))) + (let* ((init1 `(setf (%%get-unsigned-longlong ,name 0) + (%%get-unsigned-longlong ,stack-ptr ,(if (eq first8 :integer) (next-gpr) (next-fpr)))))) + (when name (inits init1))) (if second8 - (inits `(setf (%%get-unsigned-longlong ,name 8) - (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr))))))))) - (lets (list name - `(, - (ecase (foreign-type-to-representation-type argtype) - (:single-float (setq fp t) '%get-single-float) - (:double-float (setq fp t) '%get-double-float) - (:signed-doubleword '%%get-signed-longlong) - (:signed-fullword '%get-signed-long) - (:signed-halfword '%get-signed-word) - (:signed-byte '%get-signed-byte) - (:unsigned-doubleword '%%get-unsigned-longlong) - (:unsigned-fullword '%get-unsigned-long) - (:unsigned-halfword '%get-unsigned-word) - (:unsigned-byte '%get-unsigned-byte) - (:address - #+nil - (dynamic-extent-names name) - '%get-ptr)) - ,stack-ptr - ,(if fp (next-fpr) (next-gpr)))))))))))) + (let* ((init2 `(setf (%%get-unsigned-longlong ,name 8) + (%%get-unsigned-longlong ,stack-ptr ,(if (eq second8 :integer) (next-gpr) (next-fpr)))))) + (when name (inits init2 ))))))) + (let* ((form`(, + (ecase (foreign-type-to-representation-type argtype) + (:single-float (setq fp t) '%get-single-float) + (:double-float (setq fp t) '%get-double-float) + (:signed-doubleword '%%get-signed-longlong) + (:signed-fullword '%get-signed-long) + (:signed-halfword '%get-signed-word) + (:signed-byte '%get-signed-byte) + (:unsigned-doubleword '%%get-unsigned-longlong) + (:unsigned-fullword '%get-unsigned-long) + (:unsigned-halfword '%get-unsigned-word) + (:unsigned-byte '%get-unsigned-byte) + (:address + #+nil + (when name (dynamic-extent-names name)) + '%get-ptr)) + ,stack-ptr + ,(if fp (next-fpr) (next-gpr))))) + (if name (lets (list name form ))))))))))) (defun x8664::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) Index: /branches/working-0711/ccl/compiler/X86/x862.lisp =================================================================== --- /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 12693) +++ /branches/working-0711/ccl/compiler/X86/x862.lisp (revision 12694) @@ -8297,5 +8297,10 @@ (defx862 x862-flet flet (seg vreg xfer vars afuncs body p2decls) - (x862-seq-fbind seg vreg xfer vars afuncs body p2decls)) + (if (dolist (afunc afuncs) + (unless (eql 0 (afunc-fn-refcount afunc)) + (return t))) + (x862-seq-fbind seg vreg xfer vars afuncs body p2decls) + (with-x86-p2-declarations p2decls + (x862-form seg vreg xfer body)))) (defx862 x862-labels labels (seg vreg xfer vars afuncs body p2decls) Index: /branches/working-0711/ccl/compiler/backend.lisp =================================================================== --- /branches/working-0711/ccl/compiler/backend.lisp (revision 12693) +++ /branches/working-0711/ccl/compiler/backend.lisp (revision 12694) @@ -222,4 +222,8 @@ (return (make-hard-crf-reg (the fixnum (ash bit 2))))))) +(defun single-float-reg-p (reg) + (and (= (hard-regspec-class reg) hard-reg-class-fpr) + (= (get-regspec-mode reg) hard-reg-class-fpr-mode-single))) + (defun use-fp-temp (n) (setq *available-backend-fp-temps* (logand *available-backend-fp-temps* (lognot (ash 1 n)))) Index: /branches/working-0711/ccl/lib/ffi-darwinppc32.lisp =================================================================== --- /branches/working-0711/ccl/lib/ffi-darwinppc32.lisp (revision 12693) +++ /branches/working-0711/ccl/lib/ffi-darwinppc32.lisp (revision 12694) @@ -211,10 +211,14 @@ (if type0 (progn - (rlets (list name (foreign-record-type-name argtype))) - (inits `(setf ,(%foreign-access-form name type0 0 nil) + (when name (rlets (list name (foreign-record-type-name argtype)))) + (let* ((init `(setf ,(%foreign-access-form name type0 0 nil) ,(next-scalar-arg type0)))) - (progn (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) - (lets (list name `(%inc-ptr ,stack-ptr ,offset )))))) - (lets (list name (next-scalar-arg argtype)))) + (when name (inits init)))) + (progn + (setq delta (* (ceiling (foreign-record-type-bits argtype) 32) 4)) + (when name ; no side-efects hers + (lets (list name `(%inc-ptr ,stack-ptr ,offset))))))) + (let* ((pair (list name (next-scalar-arg argtype)))) + (when name (lets pair)))) #+nil (when (or (typep argtype 'foreign-pointer-type) Index: /branches/working-0711/ccl/lib/ffi-darwinppc64.lisp =================================================================== --- /branches/working-0711/ccl/lib/ffi-darwinppc64.lisp (revision 12693) +++ /branches/working-0711/ccl/lib/ffi-darwinppc64.lisp (revision 12694) @@ -457,5 +457,5 @@ (= bits 128)) (progn (setq delta (* (ceiling bits 64) 8)) - (lets (list name `(%inc-ptr ,stack-ptr ,offset ))) + (when name (lets (list name `(%inc-ptr ,stack-ptr ,offset )))) (incf offset delta)) @@ -477,31 +477,38 @@ 'foreign-single-float-type)) (return t)))))) - (rlets (list name (or (foreign-record-type-name argtype) - spec))) + (when name (rlets (list name (or (foreign-record-type-name argtype) + spec)))) (do* ((bit-offset 0 (+ bit-offset 64)) (byte-offset 0 (+ byte-offset 8))) ((>= bit-offset bits)) (if (double-float-at-offset bit-offset) - (inits `(setf (%get-double-float ,name ,byte-offset) - ,(next-scalar-arg (parse-foreign-type :double-float)))) + (let* ((init `(setf (%get-double-float ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type :double-float))))) + (when name + (inits init))) (let* ((high-single (single-float-at-offset bit-offset)) - (low-single (single-float-at-offset (+ bit-offset 32)))) - (inits `(setf (%%get-unsigned-longlong ,name ,byte-offset) - ,(next-scalar-arg (parse-foreign-type '(:unsigned 64))))) + (low-single (single-float-at-offset (+ bit-offset 32))) + (init `(setf (%%get-unsigned-longlong ,name ,byte-offset) + ,(next-scalar-arg (parse-foreign-type '(:unsigned 64)))))) + (when name (inits init)) (when high-single (when (< (incf fp-arg-num) 14) (set-fp-regs-form) - (inits `(setf (%get-single-float ,name ,byte-offset) + (when name + (inits `(setf (%get-single-float ,name ,byte-offset) (%get-single-float-from-double-ptr ,fp-args-ptr - ,(* 8 (1- fp-arg-num))))))) + ,(* 8 (1- fp-arg-num)))))))) (when low-single (when (< (incf fp-arg-num) 14) (set-fp-regs-form) - (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) + (when name + (inits `(setf (%get-single-float ,name ,(+ 4 byte-offset)) (%get-single-float-from-double-ptr ,fp-args-ptr - ,(* 8 (1- fp-arg-num))))))))))))) - (lets (list name (next-scalar-arg argtype)))) + ,(* 8 (1- fp-arg-num)))))))))))))) + (let* ((pair (list name (next-scalar-arg argtype)))) + (when name + (lets name)))) #+nil (when (or (typep argtype 'foreign-pointer-type) Index: /branches/working-0711/ccl/lib/ffi-linuxppc32.lisp =================================================================== --- /branches/working-0711/ccl/lib/ffi-linuxppc32.lisp (revision 12693) +++ /branches/working-0711/ccl/lib/ffi-linuxppc32.lisp (revision 12694) @@ -187,5 +187,5 @@ ,stack-ptr ,(+ target bias)))) - (lets (list name access-form)) + (when name (lets (list name access-form))) #+nil (when (eq spec :address) Index: /branches/working-0711/ccl/lib/ffi-linuxppc64.lisp =================================================================== --- /branches/working-0711/ccl/lib/ffi-linuxppc64.lisp (revision 12693) +++ /branches/working-0711/ccl/lib/ffi-linuxppc64.lisp (revision 12694) @@ -111,8 +111,8 @@ (< bits 64)) (progn - (rlets (list name (foreign-record-type-name argtype))) - (inits `(setf (%%get-unsigned-longlong ,name 0) - (ash (%%get-unsigned-longlong ,stack-ptr ,offset) - ,(- 64 bits))))) + (when name (rlets (list name (foreign-record-type-name argtype)))) + (when name (inits `(setf (%%get-unsigned-longlong ,name 0) + (ash (%%get-unsigned-longlong ,stack-ptr ,offset) + ,(- 64 bits)))))) (let* ((access-form `(,(cond @@ -169,5 +169,6 @@ ,(if use-fp-args (* 8 (1- fp-arg-num)) `(+ ,offset ,bias))))) - (lets (list name access-form)) + (when name (lets (list name access-form))) + #+nil (when (eq spec :address) (dynamic-extent-names name)) Index: /branches/working-0711/ccl/lib/ffi-win64.lisp =================================================================== --- /branches/working-0711/ccl/lib/ffi-win64.lisp (revision 12693) +++ /branches/working-0711/ccl/lib/ffi-win64.lisp (revision 12694) @@ -137,6 +137,6 @@ (if (typep argtype 'foreign-record-type) (setq argtype :address)) - (lets (list name - `(, + (let* ((access-form + `(, (ecase (foreign-type-to-representation-type argtype) (:single-float (setq fp t) '%get-single-float) @@ -155,5 +155,6 @@ '%get-ptr)) ,stack-ptr - ,(if fp (next-fpr) (next-gpr))))))))))) + ,(if fp (next-fpr) (next-gpr))))) + (when name (lets (list name access-form)))))))))) (defun win64::generate-callback-return-value (stack-ptr fp-args-ptr result return-type struct-return-arg) Index: /branches/working-0711/ccl/lib/macros.lisp =================================================================== --- /branches/working-0711/ccl/lib/macros.lisp (revision 12693) +++ /branches/working-0711/ccl/lib/macros.lisp (revision 12694) @@ -2653,7 +2653,7 @@ (destructuring-bind (stack-ptr fp-args-ptr lets rlets inits dynamic-extent-decls other-decls body return-type struct-return-arg error-return error-delta) args (declare (ignorable dynamic-extent-decls)) - (let* ((result (gensym)) - (condition-name (if (atom error-return) 'error (car error-return))) + (let* ((condition-name (if (atom error-return) 'error (car error-return))) (error-return-function (if (atom error-return) error-return (cadr error-return))) + (result (if struct-return-arg (gensym))) (body `(rlet ,rlets @@ -2662,15 +2662,23 @@ ,@other-decls ,@inits - (let ((,result (progn ,@body))) - (declare (ignorable ,result) - (dynamic-extent ,result)) - - ,(funcall (ftd-callback-return-value-function *target-ftd*) - stack-ptr - fp-args-ptr - result - return-type - struct-return-arg) - nil))))) + ,(if result + `(let* ((,result ,@body)) + (declare (dynamic-extent ,result) + (ignorable ,result)) + ,(funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + result + return-type + struct-return-arg)) + (if (eq return-type *void-foreign-type*) + `(progn ,@body) + (funcall (ftd-callback-return-value-function *target-ftd*) + stack-ptr + fp-args-ptr + `(progn ,@body) + return-type + struct-return-arg))) + nil)))) (if error-return (let* ((cond (gensym)) @@ -2679,10 +2687,10 @@ `(block ,block (let* ((,handler (lambda (,cond) - (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)) - (return-from ,block - nil)))) + (,error-return-function ,cond ,stack-ptr (%inc-ptr ,stack-ptr ,error-delta)) + (return-from ,block + nil)))) (declare (dynamic-extent ,handler)) - (handler-bind ((,condition-name ,handler)) - (values ,body))))) + (handler-bind ((,condition-name ,handler)) + (values ,body))))) body))))