From: Juho Snellman <jsnell@iki.fi>
Date: Tue, 1 Feb 2005 03:00:01 +0000 (+0000)
Subject: 0.18.19.10:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=dcb7dbc4a93f413d7ce2cd0d05e13c2a7e785e79;p=sbcl.git

0.18.19.10:
	Refactor sign-extension of signed c-call return values on x86-64:
        * Also sign extend short ints (fixes bug reported by Kevin Rosenberg
          on sbcl-devel, "FFI size error in sbcl-amd64").
        * Move the sign-extension to a :naturalize-gen alien-type-method.
        * Remove signed-byte-32 ptype (used only for some sign-extension
          hacks, which have now been removed).
        * Add some tests.
---

diff --git a/src/compiler/generic/primtype.lisp b/src/compiler/generic/primtype.lisp
index d11bcf6..9da94af 100644
--- a/src/compiler/generic/primtype.lisp
+++ b/src/compiler/generic/primtype.lisp
@@ -41,8 +41,7 @@
   :type (unsigned-byte 64))
 (!def-primitive-type fixnum (any-reg signed-reg)
   :type (signed-byte #.(1+ sb!vm:n-positive-fixnum-bits)))
-;; x86-64 needs a signed-byte-32 for proper handling of c-call return values.
-#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or x86-64))
+#!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 32) '(and) '(or))
 (!def-primitive-type signed-byte-32 (signed-reg descriptor-reg)
   :type (signed-byte 32))
 #!+#.(cl:if (cl:= sb!vm::n-machine-word-bits 64) '(and) '(or))
diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 9b75626..05235ba 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -81,13 +81,16 @@
     (setf (result-state-num-results state) (1+ num-results))
     (multiple-value-bind (ptype reg-sc)
 	(if (alien-integer-type-signed type)
-	    (values (if (= (sb!alien::alien-integer-type-bits type) 32)
-			'signed-byte-32
-			'signed-byte-64)
-		    'signed-reg)
+	    (values 'signed-byte-64 'signed-reg)
 	    (values 'unsigned-byte-64 'unsigned-reg))
       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 
+(define-alien-type-method (integer :naturalize-gen) (type alien)
+  (if (and (alien-integer-type-signed type)
+	   (<= (alien-type-bits type) 32))
+      `(sign-extend ,alien)
+      alien))
+
 (define-alien-type-method (system-area-pointer :result-tn) (type state)
   (declare (ignore type))
   (let ((num-results (result-state-num-results state)))
@@ -184,8 +187,28 @@
                                     ,@(new-args))))))
         (sb!c::give-up-ir1-transform))))
 
+;;; The ABI specifies that signed short/int's are returned as 32-bit
+;;; values. Negative values need to be sign-extended to 64-bits (done
+;;; in a :NATURALIZE-GEN alien-type-method).
+(defknown sign-extend (fixnum) fixnum (foldable flushable movable))  	  
 
-
+(define-vop (sign-extend)
+  (:translate sign-extend)
+  (:policy :fast-safe)
+  (:args (val :scs (any-reg)))
+  (:arg-types fixnum)
+  (:results (res :scs (any-reg)))
+  (:result-types fixnum)
+  (:generator 1
+   (inst movsxd res
+	 (make-random-tn :kind :normal
+			 :sc (sc-or-lose 'dword-reg)
+			 :offset (tn-offset val)))))
+
+(defun sign-extend (x)
+  (if (logbitp 31 x)
+      (dpb x (byte 32 0) -1)
+      (ldb (byte 32 0) x)))
 
 (define-vop (foreign-symbol-address)
   (:translate foreign-symbol-address)
@@ -217,6 +240,7 @@
   (:temporary (:sc unsigned-reg :offset rax-offset :to :result) rax)
   (:temporary (:sc unsigned-reg :offset rcx-offset
 		   :from :eval :to :result) rcx)
+  (:ignore results)
   (:vop-var vop)
   (:save-p t)
   (:generator 0
@@ -230,16 +254,6 @@
     (inst call function)
     ;; To give the debugger a clue. XX not really internal-error?
     (note-this-location vop :internal-error)
-    ;; Sign-extend s-b-32 return values.
-    (dolist (res (if (listp results)
-		     results
-		     (list results)))
-      (let ((tn (tn-ref-tn res)))	       
-	(when (eq (sb!c::tn-primitive-type tn)
-		  (primitive-type-or-lose 'signed-byte-32))
-	  (inst movsxd tn (make-random-tn :kind :normal
-					  :sc (sc-or-lose 'dword-reg)
-					  :offset (tn-offset tn))))))
     ;; FLOAT15 needs to contain FP zero in Lispland
     (inst xor rcx rcx)
     (inst movd (make-random-tn :kind :normal 
diff --git a/tests/foreign.test.sh b/tests/foreign.test.sh
index bd91bfe..f3d12b8 100644
--- a/tests/foreign.test.sh
+++ b/tests/foreign.test.sh
@@ -37,6 +37,9 @@ build_so() {
 echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c
 echo 'int numberish = 42;' >> $testfilestem.c
 echo 'int nummish(int x) { return numberish + x; }' >> $testfilestem.c
+echo 'short negative_short() { return -1; }' >> $testfilestem.c
+echo 'int negative_int()     { return -2; }' >> $testfilestem.c
+echo 'long negative_long()   { return -3; }' >> $testfilestem.c
 build_so $testfilestem
 
 echo 'int foo = 13;' > $testfilestem-b.c
@@ -72,6 +75,10 @@ cat > $testfilestem.def.lisp <<EOF
   (define-alien-variable "foo" int)
   (define-alien-routine "bar" int)
 
+  (define-alien-routine "negative_short" short)
+  (define-alien-routine "negative_int" int)
+  (define-alien-routine "negative_long" long)
+
   ;; Test that loading an object file didn't screw up our records
   ;; of variables visible in runtime. (This was a bug until 
   ;; Nikodemus Siivola's patch in sbcl-0.8.5.50.)
@@ -100,6 +107,10 @@ cat > $testfilestem.test.lisp <<EOF
   (assert (= 13 numberish))
   (assert (= 14 (nummish 1)))
 
+  (assert (= -1 (negative-short)))
+  (assert (= -2 (negative-int)))
+  (assert (= -3 (negative-long)))
+
   (print :stage-1)
 
   ;; test realoading object file with new definitions
diff --git a/version.lisp-expr b/version.lisp-expr
index 0679c42..96f5a5a 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.8.19.9"
+"0.8.19.10"