Make MAKE-LISP-OBJ pickier on CHENEYGC.

[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 afbe857..d90427f 100644 (file)
--- 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)
@@ -191,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)
@@ -262,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)
@@ -282,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)))