0.9.10.17: fix bug #400, aka more correct CONSTANTP

[sbcl.git] / src / compiler / aliencomp.lisp

diff --git a/src/compiler/aliencomp.lisp b/src/compiler/aliencomp.lisp
index 92a9128..03de07c 100644 (file)
--- a/src/compiler/aliencomp.lisp
+++ b/src/compiler/aliencomp.lisp
@@ -664,22 +664,34 @@
   (dolist (arg args)
     (annotate-ordinary-lvar arg)))
 
+;;; We support both the stdcall and cdecl calling conventions on win32 by
+;;; resetting ESP after the foreign function returns. This way it works
+;;; correctly whether the party that is supposed to pop arguments from
+;;; the stack is the caller (cdecl) or the callee (stdcall).
 (defoptimizer (%alien-funcall ir2-convert)
               ((function type &rest args) call block)
   (let ((type (if (constant-lvar-p type)
                   (lvar-value type)
                   (error "Something is broken.")))
         (lvar (node-lvar call))
-        (args args))
+        (args args)
+        #!+(or (and x86 darwin) win32) (stack-pointer (make-stack-pointer-tn)))
     (multiple-value-bind (nsp stack-frame-size arg-tns result-tns)
         (make-call-out-tns type)
+      #!+x86 (vop set-fpu-word-for-c call block)
+      #!+(or (and x86 darwin) win32) (vop current-stack-pointer call block stack-pointer)
       (vop alloc-number-stack-space call block stack-frame-size nsp)
       (dolist (tn arg-tns)
-        (let* ((arg (pop args))
-               (sc (tn-sc tn))
+        ;; On PPC, TN might be a list. This is used to indicate
+        ;; something special needs to happen. See below.
+        ;;
+        ;; FIXME: We should implement something better than this.
+        (let* ((first-tn (if (listp tn) (car tn) tn))
+               (arg (pop args))
+               (sc (tn-sc first-tn))
                (scn (sc-number sc))
-               #!-(or x86 x86-64) (temp-tn (make-representation-tn (tn-primitive-type tn)
-                                                       scn))
+               #!-(or x86 x86-64) (temp-tn (make-representation-tn
+                                            (tn-primitive-type first-tn) scn))
                (move-arg-vops (svref (sc-move-arg-vops sc) scn)))
           (aver arg)
           (unless (= (length move-arg-vops) 1)
@@ -689,7 +701,7 @@
                                          (first move-arg-vops)
                                          (lvar-tn call block arg)
                                          nsp
-                                         tn)
+                                         first-tn)
           #!-(or x86 x86-64) (progn
                    (emit-move call
                               block
@@ -700,13 +712,29 @@
                                            (first move-arg-vops)
                                            temp-tn
                                            nsp
-                                           tn))))
+                                           first-tn))
+          #!+(and ppc darwin)
+          (when (listp tn)
+            ;; This means that we have a float arg that we need to
+            ;; also copy to some int regs. The list contains the TN
+            ;; for the float as well as the TNs to use for the int
+            ;; arg.
+            (destructuring-bind (float-tn i1-tn &optional i2-tn)
+                tn
+              (if i2-tn
+                  (vop sb!vm::move-double-to-int-arg call block
+                       float-tn i1-tn i2-tn)
+                  (vop sb!vm::move-single-to-int-arg call block
+                       float-tn i1-tn))))))
       (aver (null args))
       (unless (listp result-tns)
         (setf result-tns (list result-tns)))
-      (vop* call-out call block
-            ((lvar-tn call block function)
-             (reference-tn-list arg-tns nil))
-            ((reference-tn-list result-tns t)))
-      (vop dealloc-number-stack-space call block stack-frame-size)
+      (let ((arg-tns (flatten-list arg-tns)))
+        (vop* call-out call block
+              ((lvar-tn call block function)
+               (reference-tn-list arg-tns nil))
+              ((reference-tn-list result-tns t))))
+      #!-(or (and darwin x86) win32) (vop dealloc-number-stack-space call block stack-frame-size)
+      #!+(or (and darwin x86) win32) (vop reset-stack-pointer call block stack-pointer)
+      #!+x86 (vop set-fpu-word-for-lisp call block)
       (move-lvar-result call block result-tns lvar))))