Improve basic block ordering for some loops.

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

diff --git a/src/compiler/x86/c-call.lisp b/src/compiler/x86/c-call.lisp
index b202a24..8cd0e07 100644 (file)
--- a/src/compiler/x86/c-call.lisp
+++ b/src/compiler/x86/c-call.lisp
@@ -79,9 +79,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) 16))
-      `(sign-extend ,alien ,(alien-type-bits type))
+  (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)
@@ -189,8 +190,10 @@
 
 ;;; 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.
-(defknown sign-extend ((signed-byte 16) t) fixnum
+;;; 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)
@@ -200,7 +203,7 @@
   ;; 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 fixnum (:constant fixnum))
+  (:arg-types signed-num (:constant fixnum))
   (:info size)
   (:results (res :scs (signed-reg)))
   (:result-types fixnum)
@@ -215,7 +218,7 @@
 
 #-sb-xc-host
 (defun sign-extend (x size)
-  (declare (type fixnum x))
+  (declare (type (signed-byte 32) x))
   (ecase size
     (8 (sign-extend x size))
     (16 (sign-extend x size))))
@@ -259,15 +262,24 @@
                    :from :eval :to :result) ecx)
   (:temporary (:sc unsigned-reg :offset edx-offset
                    :from :eval :to :result) edx)
-  (:node-var node)
+  #!+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)
   (:vop-var vop)
   (:save-p t)
-  (:ignore args ecx edx)
+  (:ignore args ecx edx
+           #!+sb-safepoint esi
+           #!+sb-safepoint edi)
   (:generator 0
     ;; FIXME & OAOOM: This is brittle and error-prone to maintain two
     ;; instances of the same logic, on in arch-assem.S, and one in
     ;; c-call.lisp. If you modify this, modify that one too...
-    (cond ((policy node (> space speed))
+    (cond ((and
+            ;; On safepoints builds, we currently use the out-of-line
+            ;; calling routine irrespectively of SPACE and SPEED policy.
+            ;; An inline version of said changes is left to the
+            ;; sufficiently motivated maintainer.
+            #!-sb-safepoint (policy node (> space speed)))
            (move eax function)
            (inst call (make-fixup "call_into_c" :foreign)))
           (t
@@ -343,9 +355,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
@@ -363,9 +376,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)
@@ -410,15 +424,23 @@ pointer to the arguments."
               (inst push eax)                       ; arg1
               (inst push (ash index 2))             ; arg0
 
-              ;; Indirect the access to ENTER-ALIEN-CALLBACK through
-              ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
-              ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
-              ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
-              ;; to rebind the variable. -- JES, 2006-01-01
-              (load-symbol-value eax sb!alien::*enter-alien-callback*)
-              (inst push eax) ; function
-              (inst mov  eax (foreign-symbol-address "funcall3"))
-              (inst call eax)
+              #!+sb-safepoint
+              (progn
+                (inst mov eax (foreign-symbol-address "callback_wrapper_trampoline"))
+                (inst call eax))
+
+              #!-sb-safepoint
+              (progn
+                ;; Indirect the access to ENTER-ALIEN-CALLBACK through
+                ;; the symbol-value slot of SB-ALIEN::*ENTER-ALIEN-CALLBACK*
+                ;; to ensure it'll work even if the GC moves ENTER-ALIEN-CALLBACK.
+                ;; Skip any SB-THREAD TLS magic, since we don't expecte anyone
+                ;; to rebind the variable. -- JES, 2006-01-01
+                (load-symbol-value eax sb!alien::*enter-alien-callback*)
+                (inst push eax)         ; function
+                (inst mov  eax (foreign-symbol-address "funcall3"))
+                (inst call eax))
+
               ;; now put the result into the right register
               (cond
                 ((and (alien-integer-type-p return-type)