From 3cce7d431eb1503ecd3a91173f6e4d16d289b7bd Mon Sep 17 00:00:00 2001 From: rtoy <rtoy> Date: Sat, 12 Nov 2005 19:21:39 +0000 Subject: [PATCH] CMUCL wasn't properly calling C varargs functions because it wasn't copying float args to the int registers in addition to the float regs. This really only needs to be done for varargs functions, but we don't have a way of indicating that right now. So always copy. A simple test is (alien:alien-funcall (alien:extern-alien "printf" (function c-call:void c-call:c-string c-call:double)) "%f" pi) Still needs some work. compiler/ppc/c-call.lisp: o Make the :arg-tn method for single- and double-float return a list consisting of the Tn for the float register to use and the integer register(s) in which to save the float. compiler/aliencomp.lisp: o Tell the ir2-convert function for %alien-funcall how to handle the list of TN's that the :arg-tn method might return. Copy the float value to the integer register(s) appropriately. --- compiler/aliencomp.lisp | 36 ++++++++++++++++++++++++++---------- compiler/ppc/c-call.lisp | 37 +++++++++++++++++++++++++++---------- 2 files changed, 53 insertions(+), 20 deletions(-) diff --git a/compiler/aliencomp.lisp b/compiler/aliencomp.lisp index f2c199874..152b96a38 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 6eb13a8e0..4411a949a 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 -- GitLab