Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl Commits: db121350 by Raymond Toy at 2023-07-03T20:58:20-07:00 Modify %alien-funcall deftransform to change the integer return type When the return type is an integer and the number of bits in the integer is less than 32, rewrite the return type to be a 32-bit integer (signed or unsigned according to the original type). This fixes the issue with calling a function that returns an alien:boolean, even if we declare it to return an (alien:boolean 8). Masking still happens. But this doesn't work for unsigned char or unsigned short; masking has been elided. But examination of what gcc does shows that we always zero extend the result to eax. So masking isn't really needed in this case. Clang does the same thing. - - - - - 1 changed file: - src/compiler/x86/c-call.lisp Changes: ===================================== 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 View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/db121350dec799687bc2d519... -- View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/db121350dec799687bc2d519... You're receiving this email because of your account on gitlab.common-lisp.net.