X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fc-call.lisp;h=7eec4723a4838d0ed621ff8c3e5e9f552c570bd2;hb=13fb19c3183a0effb7c35a2d453d6c6c91726e26;hp=8c756b3403c1c288e9f8d6993e84748d84924d59;hpb=d01a6883a21ee073c1a00c401c12185dbd2a8133;p=sbcl.git

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index 8c756b3..7eec472 100644
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -78,6 +78,13 @@
             (values 'unsigned-byte-32 'unsigned-reg))
       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 
+(define-alien-type-method (integer :naturalize-gen) (type alien)
+  (if (<= (alien-type-bits type) 16)
+      (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)
   (declare (ignore type))
   (let ((num-results (result-state-num-results state)))
@@ -181,6 +188,47 @@
                                     ,@(new-args))))))
         (sb!c::give-up-ir1-transform))))
 
+;;; 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 32) t) fixnum
+    (foldable flushable movable))
+
+(define-vop (sign-extend)
+  (:translate sign-extend)
+  (:policy :fast-safe)
+  ;; Need to wire this to EAX since in x86 some dword registers don't
+  ;; have a matching word or byte register.
+  (:args (val :scs (signed-reg) :target eax))
+  (:temporary (:sc signed-reg :offset eax-offset :from :eval :to :result) eax)
+  (:arg-types signed-num (:constant fixnum))
+  (:info size)
+  (:results (res :scs (signed-reg)))
+  (:result-types fixnum)
+  (:ignore eax)
+  (:generator 1
+   (inst movsx res
+         (make-random-tn :kind :normal
+                         :sc (sc-or-lose (ecase size
+                                           (8 'byte-reg)
+                                           (16 'word-reg)))
+                         :offset (tn-offset val)))))
+
+#-sb-xc-host
+(defun sign-extend (x size)
+  (declare (type (signed-byte 32) x))
+  (ecase size
+    (8 (sign-extend x size))
+    (16 (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)
   (:policy :fast-safe)
@@ -279,6 +327,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 esp-tn))
     (unless (zerop amount)
@@ -291,6 +340,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 esp-tn)))
@@ -298,8 +348,7 @@
       (let ((delta (logandc2 (+ amount 3) 3)))
         (inst mov temp
               (make-ea-for-symbol-tls-index *alien-stack*))
-        (inst fs-segment-prefix)
-        (inst sub (make-ea :dword :base temp) delta)))
+        (inst sub (make-ea :dword :base temp) delta :fs)))
     (load-tl-symbol-value result *alien-stack*))
   #!-sb-thread
   (:generator 0
@@ -319,8 +368,7 @@
       (let ((delta (logandc2 (+ amount 3) 3)))
         (inst mov temp
               (make-ea-for-symbol-tls-index *alien-stack*))
-        (inst fs-segment-prefix)
-        (inst add (make-ea :dword :base temp) delta))))
+        (inst add (make-ea :dword :base temp) delta :fs))))
   #!-sb-thread
   (:generator 0
     (unless (zerop amount)
@@ -333,7 +381,7 @@
 ;;; that GC won't move them while foreign functions go to work.
 (define-vop (touch-object)
   (:translate touch-object)
-  (:args (object :scs (descriptor-reg)))
+  (:args (object))
   (:ignore object)
   (:policy :fast-safe)
   (:arg-types t)