X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=3c5ffae2224e0da51ba26c8374c7729d34b8bf72;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=01cf930a87b95f746f62ab4443dd85c2c80d0fde;hpb=e6f4c7523aa628ece995ee01879d3fb90eed6d9f;p=sbcl.git

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
old mode 100755
new mode 100644
index 01cf930..3c5ffae
--- 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
@@ -355,9 +375,10 @@
     (aver (not (location= result esp-tn)))
     (unless (zerop amount)
       (let ((delta (logandc2 (+ amount 3) 3)))
-        (inst mov temp
-              (make-ea-for-symbol-tls-index *alien-stack*))
-        (inst sub (make-ea :dword :base temp) delta :fs)))
+        (with-tls-ea (EA :base temp
+                         :disp-type :index
+                         :disp (make-ea-for-symbol-tls-index *alien-stack*))
+          (inst sub EA delta :maybe-fs))))
     (load-tl-symbol-value result *alien-stack*))
   #!-sb-thread
   (:generator 0
@@ -375,9 +396,10 @@
   (:generator 0
     (unless (zerop amount)
       (let ((delta (logandc2 (+ amount 3) 3)))
-        (inst mov temp
-              (make-ea-for-symbol-tls-index *alien-stack*))
-        (inst add (make-ea :dword :base temp) delta :fs))))
+        (with-tls-ea (EA :base temp
+                         :disp-type :index
+                         :disp (make-ea-for-symbol-tls-index *alien-stack*))
+          (inst add EA delta :maybe-fs)))))
   #!-sb-thread
   (:generator 0
     (unless (zerop amount)
@@ -401,7 +423,8 @@
   `(deref (sap-alien (sap+ ,sp ,offset) (* ,type))))
 
 #-sb-xc-host
-(defun alien-callback-assembler-wrapper (index return-type arg-types)
+(defun alien-callback-assembler-wrapper
+    (index return-type arg-types &optional (stack-offset 0))
   "Cons up a piece of code which calls call-callback with INDEX and a
 pointer to the arguments."
   (declare (ignore arg-types))
@@ -459,7 +482,7 @@ pointer to the arguments."
                  (error "unrecognized alien type: ~A" return-type)))
               (inst mov esp ebp)                   ; discard frame
               (inst pop ebp)                       ; restore frame pointer
-              (inst ret))
+              (inst ret stack-offset))
     (finalize-segment segment)
     ;; Now that the segment is done, convert it to a static
     ;; vector we can point foreign code to.