From: Alastair Bridgewater Date: Mon, 4 May 2009 23:09:02 +0000 (+0000) Subject: 1.0.28.11: Fix bug 316325 (x86oid alien integer result truncation) X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=e7476d980c0b4949c9416b59249d0d621c0f747d;p=sbcl.git 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 --- 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)) ;;;; 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 --- 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 --- 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 --- 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 --- 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 --- 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"