- (when values
- (aver (null (cdr values)))
- (invoke-alien-type-method :result-tn (car values)))))
-
-(defun make-arg-tns (type)
- (let* ((state (make-arg-state))
- (args (mapcar #'(lambda (arg-type)
- (invoke-alien-type-method :arg-tn arg-type state))
- (alien-fun-type-arg-types type)))
- ;; We need 8 words of cruft, and we need to round up to a multiple
- ;; of 16 words.
- (frame-size (logandc2 (+ (arg-state-args state) 8 15) 15)))
- (values
- (mapcar #'(lambda (arg)
- (declare (type arg-info arg))
- (let ((offset (arg-info-offset arg))
- (prim-type (arg-info-prim-type arg)))
- (cond ((>= offset 4)
- (my-make-wired-tn prim-type (arg-info-stack-sc arg)
- (- frame-size offset 8 1)))
- ((or (eq prim-type 'single-float)
- (eq prim-type 'double-float))
- (my-make-wired-tn prim-type (arg-info-reg-sc arg)
- (+ offset 4)))
- (t
- (my-make-wired-tn prim-type (arg-info-reg-sc arg)
- (- nl0-offset offset))))))
- args)
- (* frame-size n-word-bytes))))
-
-(!def-vm-support-routine make-call-out-tns (type)
- (declare (type alien-fun-type type))
- (multiple-value-bind
- (arg-tns stack-size)
- (make-arg-tns type)
- (values (make-normal-tn *fixnum-primitive-type*)
- stack-size
- arg-tns
- (invoke-alien-type-method
- :result-tn
- (alien-fun-type-result-type type)))))
+ (when (> (length values) 2)
+ (error "Too many result values from c-call."))
+ (mapcar (lambda (type)
+ (invoke-alien-type-method :result-tn type state))
+ values)))
+
+(defun make-call-out-tns (type)
+ (let ((arg-state (make-arg-state))
+ (nargs 0))
+ (dolist (arg-type (alien-fun-type-arg-types type))
+ (cond
+ ((alien-double-float-type-p arg-type)
+ (incf nargs (logior (1+ nargs) 1)))
+ (t (incf nargs))))
+ (setf (arg-state-nargs arg-state) (logandc2 (+ nargs 8 15) 15))
+ (collect ((arg-tns))
+ (dolist (arg-type (alien-fun-type-arg-types type))
+ (arg-tns (invoke-alien-type-method :arg-tn arg-type arg-state)))
+ (values (make-normal-tn *fixnum-primitive-type*)
+ (* n-word-bytes (logandc2 (+ nargs 8 15) 15))
+ (arg-tns)
+ (invoke-alien-type-method :result-tn
+ (alien-fun-type-result-type type)
+ (make-result-state))))))
+
+(deftransform %alien-funcall ((function type &rest args))
+ (aver (sb!c::constant-lvar-p type))
+ (let* ((type (sb!c::lvar-value type))
+ (env (sb!kernel:make-null-lexenv))
+ (arg-types (alien-fun-type-arg-types type))
+ (result-type (alien-fun-type-result-type type)))
+ (aver (= (length arg-types) (length args)))
+ ;; We need to do something special for 64-bit integer arguments
+ ;; and results.
+ (if (or (some (lambda (type)
+ (and (alien-integer-type-p type)
+ (> (sb!alien::alien-integer-type-bits type) 32)))
+ arg-types)
+ (and (alien-integer-type-p result-type)
+ (> (sb!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)
+ (> (sb!alien::alien-integer-type-bits type) 32))
+ ;; 64-bit long long types are stored in
+ ;; consecutive locations, endian word order,
+ ;; aligned to 8 bytes.
+ (when (oddp (length (new-args)))
+ (new-args nil))
+ (progn (new-args `(ash ,arg -32))
+ (new-args `(logand ,arg #xffffffff))
+ (if (oddp (length (new-arg-types)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (if (alien-integer-type-signed type)
+ (new-arg-types (parse-alien-type '(signed 32) env))
+ (new-arg-types (parse-alien-type '(unsigned 32) env)))
+ (new-arg-types (parse-alien-type '(unsigned 32) env))))
+ (t
+ (new-args arg)
+ (new-arg-types type)))))
+ (cond ((and (alien-integer-type-p result-type)
+ (> (sb!alien::alien-integer-type-bits result-type) 32))
+ (let ((new-result-type
+ (let ((sb!alien::*values-type-okay* t))
+ (parse-alien-type
+ (if (alien-integer-type-signed result-type)
+ '(values (signed 32) (unsigned 32))
+ '(values (unsigned 32) (unsigned 32)))
+ env))))
+ `(lambda (function type ,@(lambda-vars))
+ (declare (ignore type))
+ (multiple-value-bind
+ (high low)
+ (%alien-funcall function
+ ',(make-alien-fun-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-fun-type
+ :arg-types (new-arg-types)
+ :result-type result-type)
+ ,@(new-args))))))
+ (sb!c::give-up-ir1-transform))))