GitLab

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.

@@ -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

Raymond Toy pushed to branch issue-242-c-call-char-result-wrong at cmucl / cmucl

Commits:

1 changed file:

Changes: