X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fc-call.lisp;h=d90427f6324d4bc3be6b4fc2d6db416831dc2075;hb=c4b30c86e3dd1d1cc70c572a6cfffe8b84e9c34a;hp=32fb566f0d3a5a22f398c7574984cada9b97016c;hpb=ee41b142b86e50983bd885141eaf2ede02815000;p=sbcl.git

diff --git a/src/compiler/x86-64/c-call.lisp b/src/compiler/x86-64/c-call.lisp
index 32fb566..d90427f 100644
--- a/src/compiler/x86-64/c-call.lisp
+++ b/src/compiler/x86-64/c-call.lisp
@@ -74,8 +74,6 @@
     (0 eax-offset)
     (1 edx-offset)))
 
-;; XXX The return handling probably doesn't conform to the ABI
-
 (define-alien-type-method (integer :result-tn) (type state)
   (let ((num-results (result-state-num-results state)))
     (setf (result-state-num-results state) (1+ num-results))
@@ -86,9 +84,10 @@
       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 
 (define-alien-type-method (integer :naturalize-gen) (type alien)
-  (if (and (alien-integer-type-signed type)
-           (<= (alien-type-bits type) 32))
-      `(sign-extend ,alien)
+  (if (<= (alien-type-bits type) 32)
+      (if (alien-integer-type-signed type)
+          `(sign-extend ,alien ,(alien-type-bits type))
+          `(logand ,alien ,(1- (ash 1 (alien-type-bits type)))))
       alien))
 
 (define-alien-type-method (system-area-pointer :result-tn) (type state)
@@ -150,6 +149,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))
@@ -187,28 +190,44 @@
                                     ,@(new-args))))))
         (sb!c::give-up-ir1-transform))))
 
-;;; 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 32)) fixnum
-          (foldable flushable movable))
+;;; The ABI is vague about how signed sub-word integer return values
+;;; are handled, but since gcc versions >=4.3 no longer do sign
+;;; extension in the callee, we need to do it in the caller.  FIXME:
+;;; If the value to be extended is known to already be of the target
+;;; type at compile time, we can (and should) elide the extension.
+(defknown sign-extend ((signed-byte 64) t) fixnum
+    (foldable flushable movable))
 
 (define-vop (sign-extend)
   (:translate sign-extend)
   (:policy :fast-safe)
   (:args (val :scs (signed-reg)))
-  (:arg-types fixnum)
+  (:arg-types signed-num (:constant fixnum))
+  (:info size)
   (:results (res :scs (signed-reg)))
   (:result-types fixnum)
   (:generator 1
    (inst movsxd res
          (make-random-tn :kind :normal
-                         :sc (sc-or-lose 'dword-reg)
+                         :sc (sc-or-lose (ecase size
+                                           (8 'byte-reg)
+                                           (16 'word-reg)
+                                           (32 'dword-reg)))
                          :offset (tn-offset val)))))
 
-(defun sign-extend (x)
-  (declare (type (signed-byte 32) x))
-  (sign-extend x))
+#-sb-xc-host
+(defun sign-extend (x size)
+  (declare (type (signed-byte 64) x))
+  (ecase size
+    (8 (sign-extend x size))
+    (16 (sign-extend x size))
+    (32 (sign-extend x size))))
+
+#+sb-xc-host
+(defun sign-extend (x size)
+  (if (logbitp (1- size) x)
+      (dpb x (byte size 0) -1)
+      x))
 
 (define-vop (foreign-symbol-sap)
   (:translate foreign-symbol-sap)
@@ -258,6 +277,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)
@@ -278,6 +298,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)))
@@ -331,27 +352,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