[Git][cmucl/cmucl][issue-242-c-call-char-result-wrong] Modify %alien-funcall deftransform to change the integer return type
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Tue Jul 4 04:02:23 UTC 2023
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/db121350dec799687bc2d51972cd350e7055ffcc
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/commit/db121350dec799687bc2d51972cd350e7055ffcc
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230704/beaaf635/attachment-0001.html>
More information about the cmucl-cvs
mailing list