From e36329167e5f536e3d33a2407c9bc74008581a0d Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Sun, 8 Jan 2006 03:06:11 +0000 Subject: [PATCH] 0.9.8.23: Add x86-64 support for passing alien callback parameters on the stack. --- src/compiler/x86-64/c-call.lisp | 50 +++++++++++++++++------ tests/callback.impure.lisp | 84 +++++++++++++-------------------------- version.lisp-expr | 2 +- 3 files changed, 67 insertions(+), 69 deletions(-) diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp index 0420526..c067972 100644 --- a/src/compiler/x86-64/c-call.lisp +++ b/src/compiler/x86-64/c-call.lisp @@ -377,7 +377,10 @@ (rsp rsp-tn) (xmm0 float0-tn) ([rsp] (make-ea :qword :base rsp :disp 0)) - (words-processed 0) + ;; How many arguments have been copied + (arg-count 0) + ;; How many arguments have been copied from the stack + (stack-argument-count 0) (gprs (mapcar (make-tn-maker 'any-reg) *c-call-register-arg-offsets*)) (fprs (mapcar (make-tn-maker 'double-reg) ;; Only 8 first XMM registers are used for @@ -389,21 +392,44 @@ ;; Copy arguments from registers to stack (dolist (type argument-types) (let ((integerp (not (alien-float-type-p type))) - (stack-tn (make-ea :qword :base rsp - :disp (* words-processed - n-word-bytes)))) - (incf words-processed) + ;; A TN pointing to the stack location where the + ;; current argument should be stored for the purposes + ;; of ENTER-ALIEN-CALLBACK. + (target-tn (make-ea :qword :base rsp + :disp (* arg-count + n-word-bytes))) + ;; A TN pointing to the stack location that contains + ;; the next argument passed on the stack. + (stack-arg-tn (make-ea :qword :base rsp + :disp (* (+ 1 + (length argument-types) + stack-argument-count) + n-word-bytes)))) + (incf arg-count) (cond (integerp (let ((gpr (pop gprs))) - (if gpr - (inst mov stack-tn gpr) - (out-of-registers-error)))) + ;; Argument not in register, copy it from the old + ;; stack location to a temporary register. + (unless gpr + (incf stack-argument-count) + (setf gpr temp-reg-tn) + (inst mov gpr stack-arg-tn)) + ;; Copy from either argument register or temporary + ;; register to target. + (inst mov target-tn gpr))) ((or (alien-single-float-type-p type) (alien-double-float-type-p type)) (let ((fpr (pop fprs))) - (if fpr - (inst movq stack-tn fpr) - (out-of-registers-error)))) + (cond (fpr + ;; Copy from float register to target location. + (inst movq target-tn fpr)) + (t + ;; Not in float register. Copy from stack to + ;; temporary (general purpose) register, and + ;; from there to the target location. + (incf stack-argument-count) + (inst mov temp-reg-tn stack-arg-tn) + (inst mov target-tn temp-reg-tn))))) (t (bug "Unknown alien floating point type: ~S" type))))) @@ -412,7 +438,7 @@ ;; Indirect the access to ENTER-ALIEN-CALLBACK through ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK* ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK. - ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone + ;; Skip any SB-THREAD TLS magic, since we don't expect anyone ;; to rebind the variable. -- JES, 2006-01-01 (inst mov rdi (+ nil-value (static-symbol-offset 'sb!alien::*enter-alien-callback*))) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 4918dd0..068515c 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -237,46 +237,34 @@ (with-test (:name :call-6-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i* (iota 6)) 21))) -(with-test (:name :define-7-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-7-int-callback) (define-callback-adder int int int int int int int int)) -(with-test (:name :call-7-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-7-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i-i* (iota 7)) 28))) -(with-test (:name :define-8-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-8-int-callback) (define-callback-adder int int int int int int int int int)) -(with-test (:name :call-8-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-8-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i-i-i* (iota 8)) 36))) -(with-test (:name :define-9-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-9-int-callback) (define-callback-adder int int int int int int int int int int)) -(with-test (:name :call-9-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-9-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i* (iota 9)) 45))) -(with-test (:name :define-10-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-10-int-callback) (define-callback-adder int int int int int int int int int int int)) -(with-test (:name :call-10-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-10-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i* (iota 10)) 55))) -(with-test (:name :define-11-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-11-int-callback) (define-callback-adder int int int int int int int int int int int int)) -(with-test (:name :call-11-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-11-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i* (iota 11)) 66))) -(with-test (:name :define-12-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-12-int-callback) (define-callback-adder int int int int int int int int int int int int int)) -(with-test (:name :call-12-int-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-12-int-callback) (assert (= (alien-apply *add-i-i-i-i-i-i-i-i-i-i-i-i* (iota 12)) 78))) (with-test (:name :define-2-float-callback) @@ -314,32 +302,24 @@ (with-test (:name :call-8-float-callback) (assert (= (alien-apply *add-f-f-f-f-f-f-f-f* (iota 8.0s0)) 36.0s0))) -(with-test (:name :define-9-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-9-float-callback) (define-callback-adder float float float float float float float float float float)) -(with-test (:name :call-9-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-9-float-callback) (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f* (iota 9.0s0)) 45.0s0))) -(with-test (:name :define-10-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-10-float-callback) (define-callback-adder float float float float float float float float float float float)) -(with-test (:name :call-10-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-10-float-callback) (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f* (iota 10.0s0)) 55.0s0))) -(with-test (:name :define-11-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-11-float-callback) (define-callback-adder float float float float float float float float float float float float)) -(with-test (:name :call-11-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-11-float-callback) (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f* (iota 11.0s0)) 66.0s0))) -(with-test (:name :define-12-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-12-float-callback) (define-callback-adder float float float float float float float float float float float float float)) -(with-test (:name :call-12-float-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-12-float-callback) (assert (= (alien-apply *add-f-f-f-f-f-f-f-f-f-f-f-f* (iota 12.0s0)) 78.0s0))) (with-test (:name :define-2-double-callback) @@ -377,32 +357,24 @@ (with-test (:name :call-8-double-callback) (assert (= (alien-apply *add-d-d-d-d-d-d-d-d* (iota 8.0d0)) 36.0d0))) -(with-test (:name :define-9-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-9-double-callback) (define-callback-adder double double double double double double double double double double)) -(with-test (:name :call-9-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-9-double-callback) (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d* (iota 9.0d0)) 45.0d0))) -(with-test (:name :define-10-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-10-double-callback) (define-callback-adder double double double double double double double double double double double)) -(with-test (:name :call-10-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-10-double-callback) (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d* (iota 10.0d0)) 55.0d0))) -(with-test (:name :define-11-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-11-double-callback) (define-callback-adder double double double double double double double double double double double double)) -(with-test (:name :call-11-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-11-double-callback) (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d* (iota 11.0d0)) 66.0d0))) -(with-test (:name :define-12-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :define-12-double-callback) (define-callback-adder double double double double double double double double double double double double double)) -(with-test (:name :call-12-double-callback - :fails-on '(or :x86-64)) +(with-test (:name :call-12-double-callback) (assert (= (alien-apply *add-d-d-d-d-d-d-d-d-d-d-d-d* (iota 12.0d0)) 78.0d0))) (with-test (:name :define-int-float-callback) diff --git a/version.lisp-expr b/version.lisp-expr index 84a0ff4..fa7b1a0 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.22" +"0.9.8.23" -- 1.7.10.4