0.9.8.23:

        Add x86-64 support for passing alien callback parameters on the stack.

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*)))

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)

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"