Raymond Toy pushed to branch master at cmucl / cmucl

Commits: 0a35575a by Raymond Toy at 2023-07-17T15:07:47+00:00 Fix #242: Mask out unwanted bits for integer results

- - - - - 5d4b0622 by Raymond Toy at 2023-07-17T15:07:49+00:00 Merge branch 'issue-242-c-call-char-result-wrong' into 'master'

Fix #242: Mask out unwanted bits for integer results

Closes #242

See merge request cmucl/cmucl!154 - - - - -

5 changed files:

- bin/run-tests.sh - src/code/alieneval.lisp - src/compiler/x86/c-call.lisp - tests/issues.lisp - + tests/test-return.c

Changes:

===================================== bin/run-tests.sh ===================================== @@ -47,6 +47,11 @@ function cleanup {

trap cleanup EXIT

+# Compile up the C file that is used for testing alien funcalls to +# functions that return integer types of different lengths. We use +# gcc since clang isn't always available. +(cd tests; gcc -m32 -O3 -c test-return.c) + if [ $# -eq 0 ]; then # No args so run all the tests $LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'

===================================== src/code/alieneval.lisp ===================================== @@ -170,6 +170,9 @@ (alien-rep nil :type (or null function)) (extract-gen nil :type (or null function)) (deposit-gen nil :type (or null function)) + ;; + ;; Method that accepts the alien type and the alien value. The + ;; method converts the alien value into an appropriate lisp value. (naturalize-gen nil :type (or null function)) (deport-gen nil :type (or null function)) ;; Cast? @@ -646,8 +649,26 @@

#-amd64 (def-alien-type-method (integer :naturalize-gen) (type alien) - (declare (ignore type)) - alien) + ;; Mask out any unwanted bits. Important if the C code returns + ;; values in %al, or %ax + (if (alien-integer-type-signed type) + (let ((val (gensym "VAL-"))) + (case (alien-integer-type-bits type) + ;; First, get just the low part of the alien and then + ;; sign-extend it appropriately. + (8 `(let ((,val (ldb (byte 8 0) ,alien))) + (if (> ,val #x7f) + (- ,val #x100) + ,val))) + (16 `(let ((,val (ldb (byte 16 0) ,alien))) + (if (> ,val #x7fff) + (- ,val #x10000) + ,val))) + (t alien))) + (case (alien-integer-type-bits type) + (8 `(ldb (byte 8 0) (truly-the (unsigned-byte 32) ,alien))) + (16 `(ldb (byte 16 0) (truly-the (unsigned-byte 32) ,alien))) + (t alien))))

;; signed numbers <= 32 bits need to be sign extended. ;; I really should use the movsxd instruction, but I don't @@ -694,8 +715,8 @@

(def-alien-type-class (boolean :include integer :include-args (signed)))

-(def-alien-type-translator boolean (&optional (bits vm:word-bits)) - (make-alien-boolean-type :bits bits :signed nil)) +(def-alien-type-translator boolean (&optional (bits 8)) + (make-alien-boolean-type :bits bits :signed t))

(def-alien-type-method (boolean :unparse) (type) `(boolean ,(alien-boolean-type-bits type))) @@ -705,8 +726,10 @@ `(member t nil))

(def-alien-type-method (boolean :naturalize-gen) (type alien) - (declare (ignore type)) - `(not (zerop ,alien))) + ;; Mask out any unwanted bits. Important if the C code returns + ;; values in %al, or %ax + `(not (zerop (ldb (byte ,(alien-boolean-type-bits type) 0) + ,alien))))

(def-alien-type-method (boolean :deport-gen) (type value) (declare (ignore type))

===================================== src/compiler/x86/c-call.lisp ===================================== @@ -141,59 +141,78 @@ (alien-function-type-result-type type) (make-result-state))))))

-(deftransform %alien-funcall ((function type &rest args)) - (assert (c::constant-continuation-p type)) +(defun %alien-funcall-aux (function type &rest args) + (declare (ignorable function type args)) (let* ((type (c::continuation-value type)) (arg-types (alien-function-type-arg-types type)) (result-type (alien-function-type-result-type type))) (assert (= (length arg-types) (length args))) - (if (or (some #'(lambda (type) - (and (alien-integer-type-p type) - (> (alien::alien-integer-type-bits type) 32))) - arg-types) - (and (alien-integer-type-p result-type) - (> (alien::alien-integer-type-bits result-type) 32))) - (collect ((new-args) (lambda-vars) (new-arg-types)) - (dolist (type arg-types) - (let ((arg (gensym))) - (lambda-vars arg) - (cond ((and (alien-integer-type-p type) - (> (alien::alien-integer-type-bits type) 32)) - (new-args `(logand ,arg #xffffffff)) - (new-args `(ash ,arg -32)) - (new-arg-types (parse-alien-type '(unsigned 32))) - (if (alien-integer-type-signed type) - (new-arg-types (parse-alien-type '(signed 32))) - (new-arg-types (parse-alien-type '(unsigned 32))))) - (t - (new-args arg) - (new-arg-types type))))) - (cond ((and (alien-integer-type-p result-type) - (> (alien::alien-integer-type-bits result-type) 32)) - (let ((new-result-type - (let ((alien::*values-type-okay* t)) - (parse-alien-type - (if (alien-integer-type-signed result-type) - '(values (unsigned 32) (signed 32)) - '(values (unsigned 32) (unsigned 32))))))) - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (multiple-value-bind (low high) - (%alien-funcall function - ',(make-alien-function-type - :arg-types (new-arg-types) - :result-type new-result-type) - ,@(new-args)) - (logior low (ash high 32)))))) + (unless (or (some #'(lambda (type) + (and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32))) + arg-types) + (and (alien-integer-type-p result-type) + (/= (alien::alien-integer-type-bits result-type) 32))) + (format t "give up~%") + (c::give-up)) + (collect ((new-args) (lambda-vars) (new-arg-types)) + (dolist (type arg-types) + (let ((arg (gensym))) + (lambda-vars arg) + (cond ((and (alien-integer-type-p type) + (> (alien::alien-integer-type-bits type) 32)) + (new-args `(logand ,arg #xffffffff)) + (new-args `(ash ,arg -32)) + (new-arg-types (parse-alien-type '(unsigned 32))) + (if (alien-integer-type-signed type) + (new-arg-types (parse-alien-type '(signed 32))) + (new-arg-types (parse-alien-type '(unsigned 32))))) (t - `(lambda (function type ,@(lambda-vars)) - (declare (ignore type)) - (%alien-funcall function - ',(make-alien-function-type - :arg-types (new-arg-types) - :result-type result-type) - ,@(new-args)))))) - (c::give-up)))) + (new-args arg) + (new-arg-types type))))) + (cond ((and (alien-integer-type-p result-type) + (< (alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(signed 32) + '(unsigned 32))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args))))) + ((and (alien-integer-type-p result-type) + (> (alien::alien-integer-type-bits result-type) 32)) + (let ((new-result-type + (let ((alien::*values-type-okay* t)) + (parse-alien-type + (if (alien-integer-type-signed result-type) + '(values (unsigned 32) (signed 32)) + '(values (unsigned 32) (unsigned 32))))))) + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (multiple-value-bind (low high) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type new-result-type) + ,@(new-args)) + (logior low (ash high 32)))))) + (t + `(lambda (function type ,@(lambda-vars)) + (declare (ignore type)) + (%alien-funcall function + ',(make-alien-function-type + :arg-types (new-arg-types) + :result-type result-type) + ,@(new-args)))))))) + +(deftransform %alien-funcall ((function type &rest args)) + (assert (c::constant-continuation-p type)) + (apply #'%alien-funcall-aux function type args))

(define-vop (foreign-symbol-code-address) (:translate #+linkage-table foreign-symbol-code-address

===================================== tests/issues.lisp ===================================== @@ -997,3 +997,111 @@ ;; This is the condition from the CLHS entry for enough-namestring (assert-equal (merge-pathnames enough defaults) (merge-pathnames (parse-namestring pathname nil defaults) defaults)))))) + +(define-test issue.242-load-foreign + ;; load-foreign apparently returns NIL if it succeeds. + (assert-true (eql nil (ext:load-foreign (merge-pathnames "test-return.o" *test-path*))))) + +(alien:def-alien-variable "test_arg" c-call:int) + +(define-test issue.242.test-alien-return-signed-char + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_signed_char" + (function c-call:char)))) + (sign-extend (n) + (let ((n (ldb (byte 8 0) n))) + (if (> n #x7f) + (- n #x100) + n)))) + (dolist (x '(99 -99 1023 -1023)) + (assert-equal (sign-extend x) (fun x) x)))) + +(define-test issue.242.test-alien-return-signed-short + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_short" + (function c-call:short)))) + (sign-extend (n) + (let ((n (ldb (byte 16 0) n))) + (if (> n #x7fff) + (- n #x10000) + n)))) + (dolist (x '(1023 -1023 100000 -100000)) + (assert-equal (sign-extend x) (fun x) x)))) + +(define-test issue.242.test-alien-return-signed-int + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_int" + (function c-call:int))))) + (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) + (assert-equal x (fun x) x)))) + +(define-test issue.242.test-alien-return-unsigned-char + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_char" + (function c-call:unsigned-char)))) + (expected (n) + (ldb (byte 8 0) n))) + (dolist (x '(99 -99 1023 -1023)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-unsigned-short + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_short" + (function c-call:unsigned-short)))) + (expected (n) + (ldb (byte 16 0) n))) + (dolist (x '(1023 -1023 100000 -100000)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-unsigned-int + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_unsigned_int" + (function c-call:unsigned-int)))) + (expected (n) + (ldb (byte 32 0) n))) + (dolist (x '(1023 -1023 #x7fffffff #x-80000000)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-bool + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_bool" + (function c-call:char)))) + (expected (n) + (if (zerop n) + 0 + 1))) + (dolist (x '(0 1 1000)) + (assert-equal (expected x) (fun x) x)))) + +(define-test issue.242.test-alien-return-bool.2 + (:tag :issues) + (flet ((fun (n) + (setf test-arg n) + (alien:alien-funcall + (alien:extern-alien "int_to_bool" + (function alien:boolean)))) + (expected (n) + (not (zerop n)))) + (dolist (x '(0 1 1000)) + (assert-equal (expected x) (fun x) x))))

===================================== tests/test-return.c ===================================== @@ -0,0 +1,45 @@ +#include <stdbool.h> + +int test_arg; + +signed char +int_to_signed_char() +{ + return (signed char) test_arg; +} + +short +int_to_short() +{ + return (short) test_arg; +} + +int +int_to_int() +{ + return (int) test_arg; +} + +unsigned char +int_to_unsigned_char() +{ + return (unsigned char) test_arg; +} + +unsigned short +int_to_unsigned_short() +{ + return (unsigned short) test_arg; +} + +unsigned int +int_to_unsigned_int() +{ + return (unsigned int) test_arg; +} + +_Bool int_to_bool() +{ + return (_Bool) test_arg; +} +

View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/635d07cac7d7aa3ebe04ff8...