1.0.15.36: fix bug 423

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

diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index c067972..c9d4861 100644 (file)
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -150,6 +150,10 @@
               (lambda-vars arg)
               (cond ((and (alien-integer-type-p type)
                           (> (sb!alien::alien-integer-type-bits type) 64))
+                     ;; CLH: FIXME! This should really be
+                     ;; #xffffffffffffffff. nyef says: "Passing
+                     ;; 128-bit integers to ALIEN functions on x86-64
+                     ;; believed to be broken."
                      (new-args `(logand ,arg #xffffffff))
                      (new-args `(ash ,arg -64))
                      (new-arg-types (parse-alien-type '(unsigned 64) env))
@@ -190,26 +194,32 @@
 ;;; The ABI specifies that signed short/int's are returned as 32-bit
 ;;; values. Negative values need to be sign-extended to 64-bits (done
 ;;; in a :NATURALIZE-GEN alien-type-method).
-(defknown sign-extend ((signed-byte 64)) (signed-byte 64)
+(defknown sign-extend ((signed-byte 32)) fixnum
           (foldable flushable movable))
 
 (define-vop (sign-extend)
   (:translate sign-extend)
   (:policy :fast-safe)
   (:args (val :scs (signed-reg)))
-  (:arg-types signed-byte-64)
+  (:arg-types fixnum)
   (:results (res :scs (signed-reg)))
-  (:result-types signed-byte-64)
+  (:result-types fixnum)
   (:generator 1
    (inst movsxd res
          (make-random-tn :kind :normal
                          :sc (sc-or-lose 'dword-reg)
                          :offset (tn-offset val)))))
 
+#-sb-xc-host
+(defun sign-extend (x)
+  (declare (type (signed-byte 32) x))
+  (sign-extend x))
+
+#+sb-xc-host
 (defun sign-extend (x)
   (if (logbitp 31 x)
       (dpb x (byte 32 0) -1)
-      (ldb (byte 32 0) x)))
+      x))
 
 (define-vop (foreign-symbol-sap)
   (:translate foreign-symbol-sap)
@@ -243,6 +253,8 @@
   (:vop-var vop)
   (:save-p t)
   (:generator 0
+    ;; ABI: Direction flag must be clear on function entry. -- JES, 2006-01-20
+    (inst cld)
     ;; ABI: AL contains amount of arguments passed in XMM registers
     ;; for vararg calls.
     (move-immediate rax
@@ -257,6 +269,7 @@
 (define-vop (alloc-number-stack-space)
   (:info amount)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   (:generator 0
     (aver (location= result rsp-tn))
     (unless (zerop amount)
@@ -277,6 +290,7 @@
   (:info amount)
   #!+sb-thread (:temporary (:sc unsigned-reg) temp)
   (:results (result :scs (sap-reg any-reg)))
+  (:result-types system-area-pointer)
   #!+sb-thread
   (:generator 0
     (aver (not (location= result rsp-tn)))
@@ -330,27 +344,16 @@
                                     (- other-pointer-lowtag)))
               delta)))))
 
-;;; these are not strictly part of the c-call convention, but are
-;;; needed for the WITH-PRESERVED-POINTERS macro used for "locking
-;;; down" lisp objects so that GC won't move them while foreign
-;;; functions go to work.
-
-(define-vop (push-word-on-c-stack)
-    (:translate push-word-on-c-stack)
-  (:args (val :scs (sap-reg)))
+;;; not strictly part of the c-call convention, but needed for the
+;;; WITH-PINNED-OBJECTS macro used for "locking down" lisp objects so
+;;; that GC won't move them while foreign functions go to work.
+(define-vop (touch-object)
+  (:translate touch-object)
+  (:args (object))
+  (:ignore object)
   (:policy :fast-safe)
-  (:arg-types system-area-pointer)
-  (:generator 2
-    (inst push val)))
-
-(define-vop (pop-words-from-c-stack)
-    (:translate pop-words-from-c-stack)
-  (:args)
-  (:arg-types (:constant (unsigned-byte 60)))
-  (:info number)
-  (:policy :fast-safe)
-  (:generator 2
-    (inst add rsp-tn (fixnumize number))))
+  (:arg-types t)
+  (:generator 0))
 
 ;;; Callbacks