diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp index f2c199874eb3512d5987a33f5522413c8f9770d7..152b96a382c6277dbf5b8f61b0939b20f1561b50 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.29 2004/08/03 00:12:28 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/aliencomp.lisp,v 1.30 2005/11/12 19:21:38 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -683,27 +683,43 @@ (cont (node-cont call)) (args args)) (multiple-value-bind (nsp stack-frame-size arg-tns result-tns) - (make-call-out-tns type) + (make-call-out-tns type) (vop alloc-number-stack-space call block stack-frame-size nsp) (dolist (tn arg-tns) - (let* ((arg (pop args)) - (sc (tn-sc tn)) + ;; On PPC, TN might be a list. This is used to indicate + ;; something special needs to happen. + (let* ((first-tn (if (listp tn) (car tn) tn)) + (arg (pop args)) + (sc (tn-sc first-tn)) (scn (sc-number sc)) - (temp-tn (make-representation-tn (tn-primitive-type tn) scn)) + (temp-tn (make-representation-tn (tn-primitive-type first-tn) scn)) (move-arg-vops (svref (sc-move-arg-vops sc) scn))) (assert arg) (assert (= (length move-arg-vops) 1) () "No unique move-arg-vop for moves in SC ~S." (sc-name sc)) + (emit-move call block (continuation-tn call block arg) temp-tn) (emit-move-arg-template call block (first move-arg-vops) - temp-tn nsp tn))) + temp-tn nsp first-tn) + (when (listp tn) + ;; This means that we have a float arg that we need to + ;; also copy to some int regs. + (destructuring-bind (float-tn i1-tn &optional i2-tn) + tn + (if i2-tn + (vop double-float-bits call block + float-tn i1-tn i2-tn) + (vop single-float-bits call block + float-tn i1-tn)))) + )) (assert (null args)) (unless (listp result-tns) (setf result-tns (list result-tns))) - (vop* call-out call block - ((continuation-tn call block function) - (reference-tn-list arg-tns nil)) - ((reference-tn-list result-tns t))) + (let ((arg-tns (flatten-list arg-tns))) + (vop* call-out call block + ((continuation-tn call block function) + (reference-tn-list arg-tns nil)) + ((reference-tn-list result-tns t)))) (vop dealloc-number-stack-space call block stack-frame-size) (move-continuation-result call block result-tns cont)))) diff --git a/compiler/ppc/c-call.lisp b/compiler/ppc/c-call.lisp index 6eb13a8e0d7419fe70737e2771ccf2d9d2d6cdc1..4411a949a0618f1917356d6b17dbc7e24be1ad45 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.13 2005/10/26 00:51:35 rtoy Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ppc/c-call.lisp,v 1.14 2005/11/12 19:21:39 rtoy Exp $") ;;; ;;; ********************************************************************** ;;; @@ -91,10 +91,14 @@ (gprs (arg-state-gpr-args state))) (cond ((< gprs 8) ; and by implication also (< fprs 13) ;; Corresponding GPR is kept empty for functions with fixed args + #+nil (incf (arg-state-gpr-args state)) + (incf (arg-state-fpr-args state)) - ;; Assign outgoing FPRs starting at FP1 - (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) + ;; Assign outgoing FPRs starting at FP1. See comments + ;; below for double-float. + (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 @@ -135,14 +139,27 @@ (gprs (arg-state-gpr-args state))) (cond ((< gprs 8) ; and by implication also (< fprs 13) ;; Corresponding GPRs are also kept empty - (incf (arg-state-gpr-args state) 2) - (when (> (arg-state-gpr-args state) 8) - ;; Spill one word to stack - (decf (arg-state-gpr-args state)) - (incf (arg-state-stack-frame-size state))) + #+nil + (progn + (incf (arg-state-gpr-args state) 2) + (when (> (arg-state-gpr-args state) 8) + ;; Spill one word to stack + (decf (arg-state-gpr-args state)) + (incf (arg-state-stack-frame-size state)))) (incf (arg-state-fpr-args state)) - ;; Assign outgoing FPRs starting at FP1 - (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + ;; 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. + ;; + ;; We really only need this for vararg functions, but we + ;; currently don't know that, so we do it always. + (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))) ((< 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