0.8.0.78.vector-nil-string.1:

[sbcl.git] / src / compiler / x86 / c-call.lisp

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 6f09cb7..3a4542f 100644 (file)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -132,11 +132,71 @@
                                        (alien-fun-type-result-type type)
                                        (make-result-state))))))
 
+
+(deftransform %alien-funcall ((function type &rest args) * * :node node)
+  (aver (sb!c::constant-continuation-p type))
+  (let* ((type (sb!c::continuation-value type))
+        (env (sb!c::node-lexenv node))
+         (arg-types (alien-fun-type-arg-types type))
+         (result-type (alien-fun-type-result-type type)))
+    (aver (= (length arg-types) (length args)))
+    (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))
+                     (new-args `(logand ,arg #xffffffff))
+                     (new-args `(ash ,arg -32))
+                     (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))))
+                    (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 (unsigned 32) (signed 32))
+                               '(values (unsigned 32) (unsigned 32)))
+                          env))))
+                   `(lambda (function type ,@(lambda-vars))
+                      (declare (ignore type))
+                      (multiple-value-bind (low high)
+                          (%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))))
+
+
+
+
 (define-vop (foreign-symbol-address)
   (:translate foreign-symbol-address)
   (:policy :fast-safe)
   (:args)
-  (:arg-types (:constant simple-string))
+  (:arg-types (:constant simple-base-string))
   (:info foreign-symbol)
   (:results (res :scs (sap-reg)))
   (:result-types system-area-pointer)