diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp index 152b96a382c6277dbf5b8f61b0939b20f1561b50..b782baad51d68e6b0bcc7c275e237c33f4c3db20 100644 --- a/compiler/aliencomp.lisp +++ b/compiler/aliencomp.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.30 2005/11/12 19:21:38 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.31 2005/11/17 03:33:45 rtoy Rel $") ;;; ;;; ********************************************************************** ;;; @@ -687,7 +687,9 @@ (vop alloc-number-stack-space call block stack-frame-size nsp) (dolist (tn arg-tns) ;; On PPC, TN might be a list. This is used to indicate - ;; something special needs to happen. + ;; something special needs to happen. See below. + ;; + ;; FIXME: We should implement something better than this. (let* ((first-tn (if (listp tn) (car tn) tn)) (arg (pop args)) (sc (tn-sc first-tn)) @@ -702,17 +704,19 @@ (emit-move call block (continuation-tn call block arg) temp-tn) (emit-move-arg-template call block (first move-arg-vops) temp-tn nsp first-tn) + #+(and ppc darwin) (when (listp tn) ;; This means that we have a float arg that we need to - ;; also copy to some int regs. + ;; also copy to some int regs. The list contains the TN + ;; for the float as well as the TNs to use for the int + ;; arg. (destructuring-bind (float-tn i1-tn &optional i2-tn) tn (if i2-tn - (vop double-float-bits call block + (vop ppc::move-double-to-int-arg call block float-tn i1-tn i2-tn) - (vop single-float-bits call block - float-tn i1-tn)))) - )) + (vop ppc::move-single-to-int-arg call block + float-tn i1-tn)))))) (assert (null args)) (unless (listp result-tns) (setf result-tns (list result-tns))) diff --git a/compiler/ppc/c-call.lisp b/compiler/ppc/c-call.lisp index b8ce7f51e55c83a3b3039de7740a5d8a6c08e864..15e20da4fe23010a7f1bccef2d23b922fb083344 100644 --- a/compiler/ppc/c-call.lisp +++ b/compiler/ppc/c-call.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/c-call.lisp,v 1.15 2005/11/15 03:20:32 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/c-call.lisp,v 1.16 2005/11/17 03:33:45 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -100,14 +100,7 @@ (list (my-make-wired-tn 'single-float 'single-reg (1+ fprs)) (int-arg state 'signed-byte-32 'signed-reg 'signed-stack))) ((< fprs 13) - ;; According to PowerOpen ABI, we need to pass those both in the - ;; FPRs _and_ the stack. However empiric testing on OS X/gcc - ;; shows they are only passed in FPRs, AFAICT. - ;; - ;; "I" in "AFAICT" probably refers to PRM. -- CSR, still - ;; reverse-engineering comments in 2003 :-) - ;; - ;; Yes, it does -- me :) + ;; See comments below for double-float. (incf (arg-state-fpr-args state)) (progn (incf (arg-state-stack-frame-size state)) @@ -142,7 +135,6 @@ (let ((fprs (arg-state-fpr-args state)) (gprs (arg-state-gpr-args state))) (cond ((< gprs 8) ; and by implication also (< fprs 13) - ;; Corresponding GPRs are also kept empty #+nil (progn (incf (arg-state-gpr-args state) 2) @@ -153,11 +145,11 @@ (incf (arg-state-fpr-args state)) ;; Assign outgoing FPRs starting at FP1. ;; - ;; The ABI says float values are stored in float regs. But - ;; if we're calling a varargs function, we also need to put - ;; the float into some gprs. We indicate this to - ;; %alien-funcall ir2-convert by making a list of the TNs - ;; for the float reg and for the int regs. + ;; The PowerOpen ABI says float values are stored in float + ;; regs. But if we're calling a varargs function, we also + ;; need to put the float into some gprs. We indicate this + ;; to %alien-funcall ir2-convert by making a list of the + ;; TNs for the float reg and for the int regs. ;; ;; We really only need this for vararg functions, but we ;; currently don't know that, so we do it always. @@ -165,16 +157,17 @@ (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))) ((< fprs 13) - ;; According to PowerOpen ABI, we need to pass those both in the - ;; FPRs _and_ the stack. However empiric testing on OS X/gcc - ;; shows they are only passed in FPRs, AFAICT. + ;; As above, we also need to put the float on the stack. + #+nil (progn (incf (arg-state-stack-frame-size state) 2) - (incf (arg-state-fpr-args state))) - #+nil - (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs)) - (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) - (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack))) + (incf (arg-state-fpr-args state)) + (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + (progn + (incf (arg-state-fpr-args state)) + (list (my-make-wired-tn 'double-float 'double-reg (1+ fprs)) + (int-arg state 'signed-byte-32 'signed-reg 'signed-stack) + (int-arg state 'unsigned-byte-32 'unsigned-reg 'unsigned-stack)))) (t ;; Pass on stack only (let ((stack-offset (arg-state-stack-frame-size state))) diff --git a/compiler/ppc/float.lisp b/compiler/ppc/float.lisp index b4be76979e09d2a655966a1e7b0503b2253b5cdd..59682cc6daeb6987fde8cfdeb25e9cb2113d90a9 100644 --- a/compiler/ppc/float.lisp +++ b/compiler/ppc/float.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.4 2005/06/19 02:48:08 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/float.lisp,v 1.5 2005/11/17 03:33:45 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -702,6 +702,70 @@ (loadw lo-bits float (1+ vm:double-float-value-slot) vm:other-pointer-type))))) +;; This vop and the next are intended to be used only for moving a +;; float to an integer arg location (register or stack) for C callout. +;; See %alien-funcall ir2convert in aliencomp.lisp. + +#+darwin +(define-vop (move-double-to-int-arg) + (:args (float :scs (double-reg))) + (:results (hi-bits :scs (signed-reg signed-stack)) + (lo-bits :scs (unsigned-reg unsigned-stack))) + (:temporary (:scs (double-stack)) stack-temp) + (:temporary (:scs (signed-reg)) temp) + (:arg-types double-float) + (:result-types signed-num unsigned-num) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (double-reg + (inst stfd float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (sc-case hi-bits + (signed-reg + (inst lwz hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (signed-stack + (inst lwz temp (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst stw temp nsp-tn + (* (tn-offset hi-bits) vm:word-bytes)))) + (sc-case lo-bits + (unsigned-reg + (inst lwz lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes))) + (unsigned-stack + (inst lwz temp (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) vm:word-bytes)) + (inst stw temp nsp-tn + (* (tn-offset lo-bits) vm:word-bytes)))))))) + +#+darwin +(define-vop (move-single-to-int-arg) + (:args (float :scs (single-reg))) + (:results (bits :scs (signed-reg signed-stack))) + (:temporary (:scs (double-stack)) stack-temp) + (:temporary (:scs (signed-reg)) temp) + (:arg-types single-float) + (:result-types signed-num) + (:policy :fast-safe) + (:vop-var vop) + (:generator 5 + (sc-case float + (single-reg + (inst stfs float (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (sc-case bits + (signed-reg + (inst lwz bits (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes))) + (signed-stack + (inst lwz temp (current-nfp-tn vop) + (* (tn-offset stack-temp) vm:word-bytes)) + (inst stw temp nsp-tn + (* (tn-offset bits) vm:word-bytes)))))))) + ;;;; Float mode hackery: