1.0.28.11: Fix bug 316325 (x86oid alien integer result truncation)

  Change the parameters for :alien-rep alien-type-methods to include a
"CONTEXT" parameter to indicate if the type being sought is for a
function result representation.  Ignore the new parameter on all
:alien-rep methods except for (integer :alien-rep).

  Change (integer :alien-rep) to return an integer type the full width
of a machine register when asked for the function result
representation.

  Condition out the (integer :naturalize-gen) method in
src/code/host-alieneval.lisp on x86oids (it's defined in
src/compiler/x86{,-64}/c-call.lisp).

  Change the type deriver for %alien-funcall to request the result
representation for the declared function result type.

  In src/compiler/x86{,-64}/c-call.lisp, change the (integer
:naturalize-gen) alien-type-method to do field masking of unsigned
fields when needed.

  Also in src/compiler/x86{,-64}/c-call.lisp, fix SIGN-EXTEND to not
lie to the compiler quite so badly about its argument types and add a
comment about a possible future optimization.

  Add a test to tests/alien.impure.lisp, for completeness sake.

diff --git a/src/code/host-alieneval.lisp b/src/code/host-alieneval.lisp
index db3baad..85859ab 100644 (file)
--- a/src/code/host-alieneval.lisp
+++ b/src/code/host-alieneval.lisp
@@ -364,8 +364,8 @@
   (declare (ignore type))
   'system-area-pointer)
 
-(define-alien-type-method (system-area-pointer :alien-rep) (type)
-  (declare (ignore type))
+(define-alien-type-method (system-area-pointer :alien-rep) (type context)
+  (declare (ignore type context))
   'system-area-pointer)
 
 (define-alien-type-method (system-area-pointer :naturalize-gen) (type alien)
@@ -502,8 +502,11 @@
 (defun compute-lisp-rep-type (type)
   (invoke-alien-type-method :lisp-rep type))
 
-(defun compute-alien-rep-type (type)
-  (invoke-alien-type-method :alien-rep type))
+;;; CONTEXT is either :NORMAL (the default) or :RESULT (alien function
+;;; return values).  See the :ALIEN-REP method for INTEGER for
+;;; details.
+(defun compute-alien-rep-type (type &optional (context :normal))
+  (invoke-alien-type-method :alien-rep type context))
 \f
 ;;;; default methods
 
@@ -521,8 +524,8 @@
   (declare (ignore type))
   nil)
 
-(define-alien-type-method (root :alien-rep) (type)
-  (declare (ignore type))
+(define-alien-type-method (root :alien-rep) (type context)
+  (declare (ignore type context))
   '*)
 
 (define-alien-type-method (root :naturalize-gen) (type alien)
@@ -588,10 +591,25 @@
   (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
         (alien-integer-type-bits type)))
 
-(define-alien-type-method (integer :alien-rep) (type)
-  (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
-        (alien-integer-type-bits type)))
-
+(define-alien-type-method (integer :alien-rep) (type context)
+  ;; When returning integer values that are narrower than a machine
+  ;; register from a function, some platforms leave the higher bits of
+  ;; the register uninitialized.  On those platforms, we use an
+  ;; alien-rep of the full register width when checking for purposes
+  ;; of return values and override the naturalize method to perform
+  ;; the sign extension (in compiler/target/c-call.lisp).
+  (ecase context
+    ((:normal #!-(or x86 x86-64) :result)
+     (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+           (alien-integer-type-bits type)))
+    #!+(or x86 x86-64)
+    (:result
+     (list (if (alien-integer-type-signed type) 'signed-byte 'unsigned-byte)
+           sb!vm:n-word-bits))))
+
+;;; As per the comment in the :ALIEN-REP method above, this is defined
+;;; elsewhere for x86oids.
+#!-(or x86 x86-64)
 (define-alien-type-method (integer :naturalize-gen) (type alien)
   (declare (ignore type))
   alien)
@@ -787,7 +805,8 @@
 (define-alien-type-method (float :lisp-rep) (type)
   (alien-float-type-type type))
 
-(define-alien-type-method (float :alien-rep) (type)
+(define-alien-type-method (float :alien-rep) (type context)
+  (declare (ignore context))
   (alien-float-type-type type))
 
 (define-alien-type-method (float :naturalize-gen) (type alien)

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 3ac88bb..bebc0a3 100644 (file)
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -715,7 +715,8 @@
       (error "Something is broken."))
     (values-specifier-type
      (compute-alien-rep-type
-      (alien-fun-type-result-type type)))))
+      (alien-fun-type-result-type type)
+      :result))))
 
 (defoptimizer (%alien-funcall ltn-annotate)
               ((function type &rest args) node ltn-policy)

diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 3e20c42..d90427f 100644 (file)
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -84,9 +84,10 @@
       (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-type-bits type))
+  (if (<= (alien-type-bits type) 32)
+      (if (alien-integer-type-signed type)
+          `(sign-extend ,alien ,(alien-type-bits type))
+          `(logand ,alien ,(1- (ash 1 (alien-type-bits type)))))
       alien))
 
 (define-alien-type-method (system-area-pointer :result-tn) (type state)
@@ -191,15 +192,17 @@
 
 ;;; The ABI is vague about how signed sub-word integer return values
 ;;; are handled, but since gcc versions >=4.3 no longer do sign
-;;; extension in the callee, we need to do it in the caller.
-(defknown sign-extend ((signed-byte 32) t) fixnum
+;;; extension in the callee, we need to do it in the caller.  FIXME:
+;;; If the value to be extended is known to already be of the target
+;;; type at compile time, we can (and should) elide the extension.
+(defknown sign-extend ((signed-byte 64) t) fixnum
     (foldable flushable movable))
 
 (define-vop (sign-extend)
   (:translate sign-extend)
   (:policy :fast-safe)
   (:args (val :scs (signed-reg)))
-  (:arg-types fixnum (:constant fixnum))
+  (:arg-types signed-num (:constant fixnum))
   (:info size)
   (:results (res :scs (signed-reg)))
   (:result-types fixnum)
@@ -214,7 +217,7 @@
 
 #-sb-xc-host
 (defun sign-extend (x size)
-  (declare (type fixnum x))
+  (declare (type (signed-byte 64) x))
   (ecase size
     (8 (sign-extend x size))
     (16 (sign-extend x size))

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index b202a24..7eec472 100644 (file)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -79,9 +79,10 @@
       (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) 16))
-      `(sign-extend ,alien ,(alien-type-bits type))
+  (if (<= (alien-type-bits type) 16)
+      (if (alien-integer-type-signed type)
+          `(sign-extend ,alien ,(alien-type-bits type))
+          `(logand ,alien ,(1- (ash 1 (alien-type-bits type)))))
       alien))
 
 (define-alien-type-method (system-area-pointer :result-tn) (type state)
@@ -189,8 +190,10 @@
 
 ;;; The ABI is vague about how signed sub-word integer return values
 ;;; are handled, but since gcc versions >=4.3 no longer do sign
-;;; extension in the callee, we need to do it in the caller.
-(defknown sign-extend ((signed-byte 16) t) fixnum
+;;; extension in the callee, we need to do it in the caller.  FIXME:
+;;; If the value to be extended is known to already be of the target
+;;; type at compile time, we can (and should) elide the extension.
+(defknown sign-extend ((signed-byte 32) t) fixnum
     (foldable flushable movable))
 
 (define-vop (sign-extend)
@@ -200,7 +203,7 @@
   ;; have a matching word or byte register.
   (:args (val :scs (signed-reg) :target eax))
   (:temporary (:sc signed-reg :offset eax-offset :from :eval :to :result) eax)
-  (:arg-types fixnum (:constant fixnum))
+  (:arg-types signed-num (:constant fixnum))
   (:info size)
   (:results (res :scs (signed-reg)))
   (:result-types fixnum)
@@ -215,7 +218,7 @@
 
 #-sb-xc-host
 (defun sign-extend (x size)
-  (declare (type fixnum x))
+  (declare (type (signed-byte 32) x))
   (ecase size
     (8 (sign-extend x size))
     (16 (sign-extend x size))))

diff --git a/tests/alien.impure.lisp b/tests/alien.impure.lisp
index aa14cf2..b327577 100644 (file)
--- a/tests/alien.impure.lisp
+++ b/tests/alien.impure.lisp
@@ -252,4 +252,46 @@
   (handler-bind ((warning #'error))
     (compile nil '(lambda () (multiple-value-list (bug-316075))))))
 
+
+;;; Bug #316325: "return values of alien calls assumed truncated to
+;;; correct width on x86"
+#+x86-64
+(sb-alien::define-alien-callback truncation-test (unsigned 64)
+    ((foo (unsigned 64)))
+  foo)
+#+x86
+(sb-alien::define-alien-callback truncation-test (unsigned 32)
+    ((foo (unsigned 32)))
+  foo)
+
+#+(or x86-64 x86)
+(with-test (:name bug-316325)
+  ;; This test works by defining a callback function that provides an
+  ;; identity transform over a full-width machine word, then calling
+  ;; it as if it returned a narrower type and checking to see if any
+  ;; noise in the high bits of the result are properly ignored.
+  (macrolet ((verify (type input output)
+               `(with-alien ((fun (* (function ,type
+                                               #+x86-64 (unsigned 64)
+                                               #+x86 (unsigned 32)))
+                                  :local (alien-sap truncation-test)))
+                  (let ((result (alien-funcall fun ,input)))
+                    (assert (= result ,output))))))
+    #+x86-64
+    (progn
+      (verify (unsigned 64) #x8000000000000000 #x8000000000000000)
+      (verify (signed 64)   #x8000000000000000 #x-8000000000000000)
+      (verify (signed 64)   #x7fffffffffffffff #x7fffffffffffffff)
+      (verify (unsigned 32) #x0000000180000042 #x80000042)
+      (verify (signed 32)   #x0000000180000042 #x-7fffffbe)
+      (verify (signed 32)   #xffffffff7fffffff #x7fffffff))
+    #+x86
+    (progn
+      (verify (unsigned 32) #x80000042 #x80000042)
+      (verify (signed 32)   #x80000042 #x-7fffffbe)
+      (verify (signed 32)   #x7fffffff #x7fffffff))
+    (verify (unsigned 16) #x00018042 #x8042)
+    (verify (signed 16)   #x003f8042 #x-7fbe)
+    (verify (signed 16)   #x003f7042 #x7042)))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 3d0b1c5..57e10fb 100644 (file)
--- 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".)
-"1.0.28.10"
+"1.0.28.11"