From 511f4325a18532f48f8c6f99e0a63862b7b25aed Mon Sep 17 00:00:00 2001 From: Alastair Bridgewater Date: Fri, 21 May 2010 01:03:25 +0000 Subject: [PATCH] 1.0.38.9: Integer callback result fixes. * Callback results should be typechecked based on their declared type, but stored as if they were the full width of a machine register. * Fixed sb-alien::alien-callback-lisp-wrapper-lambda to make this happen properly. * Updated corresponding tests (formerly callback.impure.lisp / sign-extension and underflow-detection) to cover 16-bit cases, which would have broken on all targets, not merely 64-bit targets. * As a minor side note, assistance in testing the changes in 1.0.38.8 was provided by one Andreas Selfjord Eriksen, but I forgot to note this fact in the commit message. Mea Culpa. --- src/code/target-alieneval.lisp | 21 +++++++++++++++------ tests/callback.impure.lisp | 29 +++++++++++++++++++---------- version.lisp-expr | 2 +- 3 files changed, 35 insertions(+), 17 deletions(-) diff --git a/src/code/target-alieneval.lisp b/src/code/target-alieneval.lisp index b596d27..2113489 100644 --- a/src/code/target-alieneval.lisp +++ b/src/code/target-alieneval.lisp @@ -822,22 +822,31 @@ ENTER-ALIEN-CALLBACK pulls the corresponsing trampoline out and calls it.") :local ,(alien-callback-accessor-form spec 'args-sap offset)) do (incf offset (alien-callback-argument-bytes spec env))) - ,(flet ((store (spec) + ,(flet ((store (spec real-type) (if spec `(setf (deref (sap-alien res-sap (* ,spec))) - (funcall function ,@arguments)) + ,(if real-type + `(the ,real-type + (funcall function ,@arguments)) + `(funcall function ,@arguments))) `(funcall function ,@arguments)))) (cond ((alien-void-type-p result-type) - (store nil)) + (store nil nil)) ((alien-integer-type-p result-type) + ;; Integer types should be padded out to a full + ;; register width, to comply with most ABI calling + ;; conventions, but should be typechecked on the + ;; declared type width, hence the following: (if (alien-integer-type-signed result-type) (store `(signed - ,(alien-type-word-aligned-bits result-type))) + ,(alien-type-word-aligned-bits result-type)) + `(signed-byte ,(alien-type-bits result-type))) (store `(unsigned - ,(alien-type-word-aligned-bits result-type))))) + ,(alien-type-word-aligned-bits result-type)) + `(unsigned-byte ,(alien-type-bits result-type))))) (t - (store (unparse-alien-type result-type))))))) + (store (unparse-alien-type result-type) nil)))))) (values)))) (defun invalid-alien-callback (&rest arguments) diff --git a/tests/callback.impure.lisp b/tests/callback.impure.lisp index 34bb23f..a06b13a 100644 --- a/tests/callback.impure.lisp +++ b/tests/callback.impure.lisp @@ -134,20 +134,29 @@ (sb-alien::alien-lambda void () (values))) -;;; tests for a sign extension problem in callback argument handling on x86-64 +;;; tests for integer-width problems in callback result handling -(defvar *add-two-ints* (sb-alien::alien-callback (function int int int) #'+)) +(defvar *add-two-ints* + (sb-alien::alien-callback (function int int int) #'+)) +(defvar *add-two-shorts* + (sb-alien::alien-callback (function short short short) #'+)) -(with-test (:name :sign-extension) - (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647))) +;;; The original test cases here were what are now (:int-result +;;; :sign-extension) and (:int-result :underflow-detection), the latter +;;; of which would fail on 64-bit platforms. Upon further investigation, +;;; it turned out that the same tests with a SHORT return type instead of +;;; an INT return type would also fail on 32-bit platforms. + +(with-test (:name (:short-result :sign-extension)) + (assert (= (alien-funcall *add-two-shorts* #x-8000 1) -32767))) -;;; On x86 This'll signal a TYPE-ERROR "The value -2147483649 is not of type -;;; (SIGNED-BYTE 32)". On x86-64 it'll wrap around to 2147483647, probably -;;; due to the sign-extension done by the (INTEGER :NATURALIZE-GEN) -;;; alien-type-method. I believe the former behaviour is the one we want. -;;; -- JES, 2005-10-16 +(with-test (:name (:short-result :underflow-detection)) + (assert (raises-error? (alien-funcall *add-two-shorts* #x-8000 -1)))) + +(with-test (:name (:int-result :sign-extension)) + (assert (= (alien-funcall *add-two-ints* #x-80000000 1) -2147483647))) -(with-test (:name :underflow-detection :fails-on :x86-64) +(with-test (:name (:int-result :underflow-detection)) (assert (raises-error? (alien-funcall *add-two-ints* #x-80000000 -1)))) ;;; tests for handling 64-bit arguments - this was causing problems on diff --git a/version.lisp-expr b/version.lisp-expr index a8abec0..c92916e 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.38.8" +"1.0.38.9" -- 1.7.10.4