From adeddfb8570bb924b4899679912b4629008b7566 Mon Sep 17 00:00:00 2001 From: Nathan Froyd Date: Wed, 4 Jan 2006 14:52:29 +0000 Subject: [PATCH] 0.9.8.9: Merge "updated ppc callback patch and tests", Cyrus Harmon, sbcl-devel 2006-01-01; * ...with a fix from Heiner Schwarte, sbcl-devel 2005-12-25. --- CREDITS | 4 ++ NEWS | 2 + src/code/target-alieneval.lisp | 6 +- src/compiler/aliencomp.lisp | 39 ++++++++--- src/compiler/ppc/c-call.lisp | 145 ++++++++++++++++++++++++---------------- src/compiler/ppc/float.lisp | 65 ++++++++++++++++++ tests/callback.impure.lisp | 139 ++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 8 files changed, 331 insertions(+), 71 deletions(-) diff --git a/CREDITS b/CREDITS index 6cfe18a..a648289 100644 --- a/CREDITS +++ b/CREDITS @@ -583,6 +583,9 @@ Bruno Haible: RATIONALIZE, replacing a less-accurate version inherited from primordial CMUCL. +Cyrus Harmon: + He fixed many PPC FFI and callback bugs. + Matthias Hoelzl: He reported and fixed COMPILE's misbehavior on macros. @@ -763,6 +766,7 @@ DTC Douglas Crosher APD Alexey Dejneka PFD Paul F. Dietz NJF Nathan Froyd +CLH Cyrus Harmon AL Arthur Lemmens DFL David Lichteblau RAM Robert MacLachlan diff --git a/NEWS b/NEWS index dbd1513..6027689 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,8 @@ changes in sbcl-0.9.9 relative to sbcl-0.9.8: * new platform: experimental support for the Windows operating system has been added. (thanks to Alastair Bridgewater) + * fixed several bugs in and robustified the PPC FFI (including + callbacks). (thanks to Cyrus Harmon and Heiner Schwarte) * optimization: faster implementation of EQUAL * fixed segfaults on x86 FreeBSD 7-current (thanks to NIIMI Satoshi) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index 70fb7bb..7a6e041 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -830,12 +830,12 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") (sb!kernel:get-lisp-obj-address result-pointer)))) (with-alien ,(loop + with offset = 0 for spec in argument-specs - for offset = 0 ; FIXME: Should this not be AND OFFSET ...? - then (+ offset (alien-callback-argument-bytes spec env)) collect `(,(pop argument-names) ,spec :local ,(alien-callback-accessor-form - spec 'args-sap offset))) + spec 'args-sap offset)) + do (incf offset (alien-callback-argument-bytes spec env))) ,(flet ((store (spec) (if spec `(setf (deref (sap-alien res-sap (* ,spec))) diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp index c7e8f3d..08f7100 100644 --- a/src/compiler/aliencomp.lisp +++ b/src/compiler/aliencomp.lisp @@ -678,11 +678,16 @@ (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. 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)) (scn (sc-number sc)) - #!-(or x86 x86-64) (temp-tn (make-representation-tn (tn-primitive-type tn) - scn)) + #!-(or x86 x86-64) (temp-tn (make-representation-tn + (tn-primitive-type first-tn) scn)) (move-arg-vops (svref (sc-move-arg-vops sc) scn))) (aver arg) (unless (= (length move-arg-vops) 1) @@ -692,7 +697,7 @@ (first move-arg-vops) (lvar-tn call block arg) nsp - tn) + first-tn) #!-(or x86 x86-64) (progn (emit-move call block @@ -703,14 +708,28 @@ (first move-arg-vops) temp-tn nsp - tn)))) + 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. 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 sb!vm::move-double-to-int-arg call block + float-tn i1-tn i2-tn) + (vop sb!vm::move-single-to-int-arg call block + float-tn i1-tn)))))) (aver (null args)) (unless (listp result-tns) (setf result-tns (list result-tns))) - (vop* call-out call block - ((lvar-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 + ((lvar-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-lvar-result call block result-tns lvar)))) diff --git a/src/compiler/ppc/c-call.lisp b/src/compiler/ppc/c-call.lisp index 8f5820f..a218792 100644 --- a/src/compiler/ppc/c-call.lisp +++ b/src/compiler/ppc/c-call.lisp @@ -82,18 +82,12 @@ (let* ((fprs (arg-state-fpr-args state)) (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 - (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))) + (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 :-) + ;; See comments below for double-float. (incf (arg-state-fpr-args state)) (incf (arg-state-stack-frame-size state)) (my-make-wired-tn 'single-float 'single-reg (1+ fprs))) @@ -123,22 +117,23 @@ (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 - (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))) + ;; + ;; 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. + ;; + (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 - ;; shows they are only passed in FPRs, AFAICT. - (incf (arg-state-stack-frame-size state) 2) (incf (arg-state-fpr-args state)) - (my-make-wired-tn 'double-float 'double-reg (1+ fprs))) + (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))) @@ -386,8 +381,23 @@ #-sb-xc-host (progn (defun alien-callback-accessor-form (type sap offset) - ;; Unaligned access is slower, but possible, so this is nice and simple. - `(deref (sap-alien (sap+ ,sap ,offset) (* ,type)))) + (let ((parsed-type + (sb!alien::parse-alien-type type (sb!kernel:make-null-lexenv)))) + (cond ((sb!alien::alien-integer-type-p parsed-type) + ;; Unaligned access is slower, but possible, so this is nice and + ;; simple. Also, we're a big-endian machine, so we need to get + ;; byte offsets correct. + (let ((bits (sb!alien::alien-type-bits parsed-type))) + (let ((byte-offset + (cond ((< bits n-word-bits) + (- n-word-bytes + (ceiling bits n-byte-bits))) + (t 0)))) + `(deref (sap-alien (sap+ ,sap + ,(+ byte-offset offset)) + (* ,type)))))) + (t + `(deref (sap-alien (sap+ ,sap ,offset) (* ,type))))))) ;;; The "Mach-O Runtime Conventions" document for OS X almost specifies ;;; the calling convention (it neglects to mention that the linkage @@ -405,40 +415,39 @@ (assemble (segment) ;; To save our arguments, we follow the algorithm sketched in the ;; "PowerPC Calling Conventions" section of that document. + ;; + ;; CLH: There are a couple problems here. First, we bail if + ;; we run out of registers. AIUI, we can just ignore the extra + ;; args here and we will be ok... (let ((words-processed 0) (gprs (mapcar #'make-gpr '(3 4 5 6 7 8 9 10))) (fprs (mapcar #'make-fpr '(1 2 3 4 5 6 7 8 9 10 11 12 13))) (stack-pointer (make-gpr 1))) - (labels ((out-of-registers-error () - (error "Too many arguments in callback")) - (save-arg (type words) + (labels ((save-arg (type words) (let ((integerp (not (alien-float-type-p type))) (offset (+ (* words-processed n-word-bytes) n-foreign-linkage-area-bytes))) (cond (integerp - (loop repeat words - for gpr = (pop gprs) - do - (if gpr - (inst stw gpr stack-pointer offset) - (out-of-registers-error)) - (incf words-processed))) - ;; The handling of floats is a little ugly - ;; because we hard-code the number of words + (dotimes (k words) + (let ((gpr (pop gprs))) + (when gpr + (inst stw gpr stack-pointer offset)) + (incf words-processed) + (incf offset n-word-bytes)))) + ;; The handling of floats is a little ugly + ;; because we hard-code the number of words ;; for single- and double-floats. ((alien-single-float-type-p type) (pop gprs) (let ((fpr (pop fprs))) - (if fpr - (inst stfs fpr stack-pointer offset) - (out-of-registers-error))) + (when fpr + (inst stfs fpr stack-pointer offset))) (incf words-processed)) ((alien-double-float-type-p type) (setf gprs (cddr gprs)) (let ((fpr (pop fprs))) - (if fpr - (inst stfd fpr stack-pointer offset) - (out-of-registers-error))) + (when fpr + (inst stfd fpr stack-pointer offset))) (incf words-processed 2)) (t (bug "Unknown alien floating point type: ~S" type)))))) @@ -466,15 +475,17 @@ +stack-alignment-bytes+))) (destructuring-bind (sp r0 arg1 arg2 arg3 arg4) (mapcar #'make-gpr '(1 0 3 4 5 6)) + ;; FIXME: This is essentially the same code as LR in + ;; insts.lisp, but attempting to use (INST LR ...) instead + ;; of this function results in callbacks not working. Why? + ;; --njf, 2006-01-04 (flet ((load-address-into (reg addr) (let ((high (ldb (byte 16 16) addr)) (low (ldb (byte 16 0) addr))) - (inst li reg high) - (inst slwi reg reg 16) + (inst lis reg high) (inst ori reg reg low)))) ;; Setup the args - (load-address-into - arg1 (get-lisp-obj-address #'enter-alien-callback)) + (load-address-into arg1 (get-lisp-obj-address #'enter-alien-callback)) (inst li arg2 (fixnumize index)) (inst addi arg3 sp n-foreign-linkage-area-bytes) ;; FIXME: This was (- (* RETURN-AREA-SIZE N-WORD-BYTES)), while @@ -496,19 +507,39 @@ (inst lwz sp sp 0) (inst lwz r0 sp (* 2 n-word-bytes)) (inst mtlr r0) - (loop with gprs = (mapcar #'make-gpr '(3 4)) - repeat n-return-area-words - for gpr = (pop gprs) - for offset downfrom (- n-word-bytes) by n-word-bytes - do - (unless gpr - (bug "Out of return registers in alien-callback trampoline.")) - (inst lwz gpr sp offset)) + (cond + ((sb!alien::alien-single-float-type-p result-type) + (let ((f1 (make-fpr 1))) + (inst lfs f1 sp (- (* n-return-area-words n-word-bytes))))) + ((sb!alien::alien-double-float-type-p result-type) + (let ((f1 (make-fpr 1))) + (inst lfd f1 sp (- (* n-return-area-words n-word-bytes))))) + ((sb!alien::alien-void-type-p result-type) + ;; Nothing to do + ) + (t + (loop with gprs = (mapcar #'make-gpr '(3 4)) + repeat n-return-area-words + for gpr = (pop gprs) + for offset from (- (* n-return-area-words n-word-bytes)) + by n-word-bytes + do + (unless gpr + (bug "Out of return registers in alien-callback trampoline.")) + (inst lwz gpr sp offset)))) (inst blr)))) (finalize-segment segment) ;; Now that the segment is done, convert it to a static ;; vector we can point foreign code to. - (let ((buffer (sb!assem::segment-buffer segment))) - (make-static-vector (length buffer) - :element-type '(unsigned-byte 8) - :initial-contents buffer)))))) + (let* ((buffer (sb!assem::segment-buffer segment)) + (vector (make-static-vector (length buffer) + :element-type '(unsigned-byte 8) + :initial-contents buffer)) + (sap (sb!sys:vector-sap vector))) + (sb!alien:alien-funcall + (sb!alien:extern-alien "ppc_flush_icache" + (function void + system-area-pointer + unsigned-long)) + sap (length buffer)) + vector))))) diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp index f4cc01b..de01833 100644 --- a/src/compiler/ppc/float.lisp +++ b/src/compiler/ppc/float.lisp @@ -852,3 +852,68 @@ (:translate imagpart) (:note "complex double float imagpart") (:variant :imag)) + +;; 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) n-word-bytes)) + (sc-case hi-bits + (signed-reg + (inst lwz hi-bits (current-nfp-tn vop) + (* (tn-offset stack-temp) n-word-bytes))) + (signed-stack + (inst lwz temp (current-nfp-tn vop) + (* (tn-offset stack-temp) n-word-bytes)) + (inst stw temp nsp-tn + (* (tn-offset hi-bits) n-word-bytes)))) + (sc-case lo-bits + (unsigned-reg + (inst lwz lo-bits (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) n-word-bytes))) + (unsigned-stack + (inst lwz temp (current-nfp-tn vop) + (* (1+ (tn-offset stack-temp)) n-word-bytes)) + (inst stw temp nsp-tn + (* (tn-offset lo-bits) n-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) n-word-bytes)) + (sc-case bits + (signed-reg + (inst lwz bits (current-nfp-tn vop) + (* (tn-offset stack-temp) n-word-bytes))) + (signed-stack + (inst lwz temp (current-nfp-tn vop) + (* (tn-offset stack-temp) n-word-bytes)) + (inst stw temp nsp-tn + (* (tn-offset bits) n-word-bytes)))))))) + diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index bc1ebe4..bda01b2 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -148,3 +148,142 @@ (with-test (:name :underflow-detection :fails-on :x86-64) (assert (raises-error? (alien-funcall *add-two-ints* #x-80000000 -1)))) + +;;; test for callbacks of various arities +;;; CLH 2005-12-21 + +(defparameter *type-abbreviations* + '((sb-alien:int . "i") + (sb-alien:float . "f") + (sb-alien:double . "d") + (sb-alien:short . "h") + (sb-alien:char . "c"))) + +(defun parse-callback-arg-spec (spec) + (let ((l (coerce spec 'list))) + (loop for g in l by #'cddr + collect (car (rassoc (string-downcase g) *type-abbreviations* :test #'equal))))) + +(macrolet ((define-callback-adder2 (return-type spec) + (let ((fname (format nil "*add-~A*" spec)) + (l (parse-callback-arg-spec spec))) + `(progn + (defparameter ,(intern (string-upcase fname)) + (sb-alien::alien-callback + (function ,return-type + ,@l) '+)))))) + (define-callback-adder2 int "i-i")) + +(macrolet ((define-callback-adder (&rest types) + (let ((fname (format nil "*add-~{~A~^-~}*" + (mapcar + #'(lambda (x) + (cdr (assoc x *type-abbreviations*))) + (mapcar + #'(lambda (y) (find-symbol (string-upcase y) 'sb-alien)) + (cdr types)))))) + `(progn + (print ,fname) + (defparameter ,(intern + (string-upcase fname)) + (sb-alien::alien-callback (function ,@types) '+)))))) + + (define-callback-adder int int int) + (define-callback-adder int int int int) + (define-callback-adder int int int int int) + (define-callback-adder int int int int int int) + (define-callback-adder int int int int int int int) + (define-callback-adder int int int int int int int int) + (define-callback-adder int int int int int int int int int) + (define-callback-adder int int int int int int int int int int) + (define-callback-adder int int int int int int int int int int int) + (define-callback-adder int int int int int int int int int int int int) + (define-callback-adder int int int int int int int int int int int int int) + + (define-callback-adder float float float) + (define-callback-adder float float float float) + (define-callback-adder float float float float float) + (define-callback-adder float float float float float float) + (define-callback-adder float float float float float float float) + (define-callback-adder float float float float float float float float) + (define-callback-adder float float float float float float float float float) + (define-callback-adder float float float float float float float float float float) + (define-callback-adder float float float float float float float float float float float) + (define-callback-adder float float float float float float float float float float float float) + (define-callback-adder float float float float float float float float float float float float float) + + (define-callback-adder double double double) + (define-callback-adder double double double double double) + (define-callback-adder double double double double double double) + (define-callback-adder double double double double double double double) + (define-callback-adder double double double double double double double double) + (define-callback-adder double double double double double double double double double) + (define-callback-adder double double double double double double double double double double) + (define-callback-adder double double double double double double double double double double double) + (define-callback-adder double double double double double double double double double double double double) + (define-callback-adder double double double double double double double double double double double double double) + + (define-callback-adder float int float) + (define-callback-adder float float int) + (define-callback-adder float float int int int) + + (define-callback-adder double double int) + (define-callback-adder double int double) + + (define-callback-adder double double float) + (define-callback-adder double float double) + + (define-callback-adder double double float int) + (define-callback-adder double int float double) + (define-callback-adder double int float double double) + + (define-callback-adder double double int int int) + (define-callback-adder double double int int int double int int int) + + (define-callback-adder double double double int int int int int int) + + (define-callback-adder double double double int int) + + (define-callback-adder double int double int double int double int double int double) + + (define-callback-adder double short double) + + (define-callback-adder double char double)) + + +(defmacro alien-apply-form (f args) + `(let ((a ,args)) + `(alien-funcall ,,f ,@a))) + +(defmacro alien-apply (f &rest args) + `(eval (alien-apply-form ,f ,@args))) + +(defun iota (x) (if (equalp x 1) (list x) (cons x (iota (1- x))))) + +(alien-funcall *add-i-i* 1 2) +(alien-funcall *add-f-f* 1.0s0 2.0s0) +(alien-funcall *add-d-d* 2.0d0 4.0d0) + +(assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36)) +(assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55)) +(assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78)) + +(assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8s0)) 36s0)) +(assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55s0)) + +(assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8d0)) 36d0)) +(assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10d0)) 55d0)) + +(assert (= (alien-funcall *add-i-i* 2 3) 5)) +(assert (= (alien-funcall *add-d-d* 2d0 3d0) 5d0)) +(assert (= (alien-funcall *add-i-d* 2 3d0) 5d0)) +(assert (= (alien-funcall *add-d-i* 2d0 3) 5d0)) +(assert (= (alien-funcall *add-d-f* 2d0 3s0) 5d0)) +(assert (= (alien-funcall *add-f-d* 2s0 3d0) 5d0)) + +(assert (= (alien-funcall *add-d-i-i-i-d-i-i-i* 1d0 2 3 4 5d0 6 7 8) 36d0)) + +(assert (= (alien-apply *add-i-d-i-d-i-d-i-d-i-d* + (mapcan #'(lambda (x y) (list x y)) (iota 5) (iota 5.0d0))) + 30d0)) + diff --git a/version.lisp-expr b/version.lisp-expr index 38ce1bd..6d9f03e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.8.8" +"0.9.8.9" -- 1.7.10.4