X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=3c5ffae2224e0da51ba26c8374c7729d34b8bf72;hb=d306e2d23b38487488eb93881dad836e439e0c77;hp=4d57b8e550816336523a4689a7e8bfa9a095c3a3;hpb=79721a8731b8582ad8df664c2c4e04bd3d6090c6;p=sbcl.git

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 4d57b8e..3c5ffae 100644
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -119,7 +119,7 @@
               (invoke-alien-type-method :result-tn type state))
             values)))
 
-(!def-vm-support-routine make-call-out-tns (type)
+(defun make-call-out-tns (type)
   (let ((arg-state (make-arg-state)))
     (collect ((arg-tns))
       (dolist (arg-type (alien-fun-type-arg-types type))
@@ -252,6 +252,21 @@
   (:generator 2
    (inst mov res (make-fixup foreign-symbol :foreign-dataref))))
 
+(defun force-x87-to-mem (tn fp-temp)
+  (aver (location= tn fr0-tn))
+  (sc-case tn
+    (single-reg
+     (let ((ea (ea-for-sf-stack fp-temp)))
+       (inst fstp ea)
+       (inst fld ea)))
+    (double-reg
+     (let ((ea (ea-for-df-stack fp-temp)))
+       (inst fstpd ea)
+       (inst fldd ea)))
+    #!+long-float
+    (long-reg  ; nothing to do!
+     )))
+
 (define-vop (call-out)
   (:args (function :scs (sap-reg))
          (args :more t))
@@ -262,6 +277,7 @@
                    :from :eval :to :result) ecx)
   (:temporary (:sc unsigned-reg :offset edx-offset
                    :from :eval :to :result) edx)
+  (:temporary (:sc double-stack) fp-temp)
   #!+sb-safepoint (:temporary (:sc unsigned-reg :offset esi-offset) esi)
   #!+sb-safepoint (:temporary (:sc unsigned-reg :offset edi-offset) edi)
   #!-sb-safepoint (:node-var node)
@@ -281,7 +297,10 @@
             ;; sufficiently motivated maintainer.
             #!-sb-safepoint (policy node (> space speed)))
            (move eax function)
-           (inst call (make-fixup "call_into_c" :foreign)))
+           (inst call (make-fixup "call_into_c" :foreign))
+           (when (and results
+                      (location= (tn-ref-tn results) fr0-tn))
+             (force-x87-to-mem (tn-ref-tn results) fp-temp)))
           (t
            ;; Setup the NPX for C; all the FP registers need to be
            ;; empty; pop them all.
@@ -300,12 +319,13 @@
            (dotimes (i 7)
              (inst fldz))
 
-           (if (and results
-                    (location= (tn-ref-tn results) fr0-tn))
-               ;; The return result is in fr0.
-               (inst fxch fr7-tn)       ; move the result back to fr0
-               (inst fldz))             ; insure no regs are empty
-           ))))
+           (cond ((and results
+                       (location= (tn-ref-tn results) fr0-tn))
+                  ;; The return result is in fr0.
+                  (inst fxch fr7-tn)       ; move the result back to fr0
+                  (force-x87-to-mem (tn-ref-tn results) fp-temp))
+                 (t ; ensure no regs are empty
+                  (inst fldz)))))))
 
 ;;; While SBCL uses the FPU in 53-bit mode, most C libraries assume that
 ;;; the FPU is in 64-bit mode. So we change the FPU mode to 64-bit with