From: Alastair Bridgewater <nyef_sbcl@lisphacker.com>
Date: Wed, 2 Dec 2009 22:18:55 +0000 (-0500)
Subject: x86-64 disentwingling of fixnums and words.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3b5fb548ed34612fb853b11b2bcdd29440834eaa;p=sbcl.git

x86-64 disentwingling of fixnums and words.

  * This is mostly constant fixups and supplying scaling factors in
places.

  * Where possible, I have used constructs that will simply generate the
correct code no matter what the width of a fixnum is.  In other places,
I have used an explicit check for the historic case and provided and
alternate code sequence for when it no longer applies.

  * Thanks to Paul Khuong for helping with the finding and fixing of
many of these places.
---

diff --git a/src/assembly/x86-64/arith.lisp b/src/assembly/x86-64/arith.lisp
index fc05cbe..684d16e 100644
--- a/src/assembly/x86-64/arith.lisp
+++ b/src/assembly/x86-64/arith.lisp
@@ -40,10 +40,10 @@
                 (inst ret)
 
                 DO-STATIC-FUN
-                ;; Same as: (inst enter (fixnumize 1))
+                ;; Same as: (inst enter (* n-word-bytes 1))
                 (inst push rbp-tn)
                 (inst mov rbp-tn rsp-tn)
-                (inst sub rsp-tn (fixnumize 1))
+                (inst sub rsp-tn (* n-word-bytes 1))
                 (inst push (make-ea :qword :base rbp-tn
                             :disp (frame-byte-offset return-pc-save-offset)))
                 (inst mov rcx (fixnumize 2)) ; arg count
@@ -53,12 +53,16 @@
                                         (static-fun-offset
                                          ',(symbolicate "TWO-ARG-" fun))))))))
 
+  #.`
   (define-generic-arith-routine (+ 10)
     (move res x)
     (inst add res y)
     (inst jmp :no OKAY)
-    (inst rcr res 1)                  ; carry has correct sign
-    (inst sar res 2)                  ; remove type bits
+    ;; Unbox the overflowed result, recovering the correct sign from
+    ;; the carry flag, then re-box as a bignum.
+    (inst rcr res 1)
+    ,@(when (> n-fixnum-tag-bits 1)   ; don't shift by 0
+            '((inst sar res (1- n-fixnum-tag-bits))))
 
     (move rcx res)
 
@@ -67,13 +71,17 @@
 
     OKAY)
 
+  #.`
   (define-generic-arith-routine (- 10)
     (move res x)
     (inst sub res y)
     (inst jmp :no OKAY)
+    ;; Unbox the overflowed result, recovering the correct sign from
+    ;; the carry flag, then re-box as a bignum.
     (inst cmc)                        ; carry has correct sign now
     (inst rcr res 1)
-    (inst sar res 2)                  ; remove type bits
+    ,@(when (> n-fixnum-tag-bits 1)   ; don't shift by 0
+            '((inst sar res (1- n-fixnum-tag-bits))))
 
     (move rcx res)
 
@@ -128,7 +136,7 @@
 
   (inst push rbp-tn)
   (inst mov rbp-tn rsp-tn)
-  (inst sub rsp-tn (fixnumize 1))
+  (inst sub rsp-tn (* n-word-bytes 1))
   (inst push (make-ea :qword :base rbp-tn
                       :disp (frame-byte-offset return-pc-save-offset)))
   (inst mov rcx (fixnumize 1))    ; arg count
@@ -168,7 +176,7 @@
                 (inst ret)
 
                 DO-STATIC-FUN
-                (inst sub rsp-tn (fixnumize 3))
+                (inst sub rsp-tn (* n-word-bytes 3))
                 (inst mov (make-ea :qword :base rsp-tn
                                    :disp (frame-byte-offset
                                           (+ sp->fp-offset
@@ -238,7 +246,7 @@
   (inst ret)
 
   DO-STATIC-FUN
-  (inst sub rsp-tn (fixnumize 3))
+  (inst sub rsp-tn (* n-word-bytes 3))
   (inst mov (make-ea :qword :base rsp-tn
                      :disp (frame-byte-offset
                             (+ sp->fp-offset
@@ -300,7 +308,7 @@
   (inst ret)
 
   DO-STATIC-FUN
-  (inst sub rsp-tn (fixnumize 3))
+  (inst sub rsp-tn (* n-word-bytes 3))
   (inst mov (make-ea :qword :base rsp-tn
                      :disp (frame-byte-offset
                             (+ sp->fp-offset
diff --git a/src/assembly/x86-64/assem-rtns.lisp b/src/assembly/x86-64/assem-rtns.lisp
index b6ea237..6799744 100644
--- a/src/assembly/x86-64/assem-rtns.lisp
+++ b/src/assembly/x86-64/assem-rtns.lisp
@@ -57,7 +57,7 @@
   ;; address. Therefore, we need to iterate from larger addresses to
   ;; smaller addresses. pfw-this says copy ecx words from esi to edi
   ;; counting down.
-  (inst shr ecx (1- n-lowtag-bits))
+  (inst shr ecx n-fixnum-tag-bits)
   (inst std)                            ; count down
   (inst sub esi n-word-bytes)
   (inst lea edi (make-ea :qword :base ebx :disp (- n-word-bytes)))
@@ -151,9 +151,11 @@
   ;; Calculate NARGS (as a fixnum)
   (move ecx esi)
   (inst sub ecx rsp-tn)
+  #!-#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or))
+  (inst shr ecx (- word-shift n-fixnum-tag-bits))
 
   ;; Check for all the args fitting the registers.
-  (inst cmp ecx (fixnumize 3))
+  (inst cmp ecx (fixnumize register-arg-count))
   (inst jmp :le REGISTER-ARGS)
 
   ;; Save the OLD-FP and RETURN-PC because the blit is going to trash
@@ -166,10 +168,10 @@
   ;; Do the blit. Because we are coping from smaller addresses to
   ;; larger addresses, we have to start at the largest pair and work
   ;; our way down.
-  (inst shr ecx (1- n-lowtag-bits))
+  (inst shr ecx n-fixnum-tag-bits)
   (inst std)                            ; count down
   (inst lea edi (make-ea :qword :base rbp-tn :disp (frame-byte-offset 0)))
-  (inst sub esi (fixnumize 1))
+  (inst sub esi n-word-bytes)
   (inst rep)
   (inst movs :qword)
   (inst cld)
diff --git a/src/compiler/x86-64/alloc.lisp b/src/compiler/x86-64/alloc.lisp
index 9e44853..fbde8b6 100644
--- a/src/compiler/x86-64/alloc.lisp
+++ b/src/compiler/x86-64/alloc.lisp
@@ -79,9 +79,10 @@
               positive-fixnum)
   (:policy :fast-safe)
   (:generator 100
-    (inst lea result (make-ea :byte :base words :disp
-                              (+ (1- (ash 1 n-lowtag-bits))
-                                 (* vector-data-offset n-word-bytes))))
+    (inst lea result (make-ea :byte :index words
+                              :scale (ash 1 (- word-shift n-fixnum-tag-bits))
+                              :disp (+ lowtag-mask
+                                       (* vector-data-offset n-word-bytes))))
     (inst and result (lognot lowtag-mask))
     (pseudo-atomic
       (allocation result result)
@@ -104,9 +105,10 @@
   (:policy :fast-safe)
   (:node-var node)
   (:generator 100
-    (inst lea result (make-ea :byte :base words :disp
-                              (+ (1- (ash 1 n-lowtag-bits))
-                                 (* vector-data-offset n-word-bytes))))
+    (inst lea result (make-ea :byte :index words
+                              :scale (ash 1 (- word-shift n-fixnum-tag-bits))
+                              :disp (+ lowtag-mask
+                                       (* vector-data-offset n-word-bytes))))
     (inst and result (lognot lowtag-mask))
     ;; FIXME: It would be good to check for stack overflow here.
     (move ecx words)
@@ -203,11 +205,13 @@
   (:node-var node)
   (:generator 50
     (inst lea bytes
-          (make-ea :qword :base extra :disp (* (1+ words) n-word-bytes)))
+          (make-ea :qword :disp (* (1+ words) n-word-bytes) :index extra
+                   :scale (ash 1 (- word-shift n-fixnum-tag-bits))))
     (inst mov header bytes)
-    (inst shl header (- n-widetag-bits 3)) ; w+1 to length field
+    (inst shl header (- n-widetag-bits word-shift)) ; w+1 to length field
     (inst lea header                    ; (w-1 << 8) | type
-          (make-ea :qword :base header :disp (+ (ash -2 n-widetag-bits) type)))
+          (make-ea :qword :base header
+                   :disp (+ (ash -2 n-widetag-bits) type)))
     (inst and bytes (lognot lowtag-mask))
     (pseudo-atomic
      (allocation result bytes node)
diff --git a/src/compiler/x86-64/arith.lisp b/src/compiler/x86-64/arith.lisp
index 3c6420f..0e0be28 100644
--- a/src/compiler/x86-64/arith.lisp
+++ b/src/compiler/x86-64/arith.lisp
@@ -391,7 +391,7 @@
   (:note "inline fixnum arithmetic")
   (:generator 4
     (move r x)
-    (inst sar r 3)
+    (inst sar r n-fixnum-tag-bits)
     (inst imul r y)))
 
 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
@@ -686,6 +686,7 @@
                       (progn
                         (inst sar result (- amount))
                         (inst and result (lognot fixnum-tag-mask)))))
+                 ;; shifting left (zero fill)
                  ((plusp amount)
                   (unless modularp
                     (aver (not "Impossible: fixnum ASH should not be called with
@@ -693,6 +694,7 @@ constant shift greater than word length")))
                   (if (sc-is result any-reg)
                       (zeroize result)
                       (inst mov result 0)))
+                 ;; shifting right (sign fill)
                  (t (inst sar result 63)
                     (inst and result (lognot fixnum-tag-mask))))))))
 
@@ -1664,7 +1666,7 @@ constant shift greater than word length")))
   (:result-types unsigned-num)
   (:generator 1
     (move digit fixnum)
-    (inst sar digit 3)))
+    (inst sar digit n-fixnum-tag-bits)))
 
 (define-vop (bignum-floor)
   (:translate sb!bignum:%bigfloor)
@@ -1700,7 +1702,7 @@ constant shift greater than word length")))
   (:generator 1
     (move res digit)
     (when (sc-is res any-reg control-stack)
-      (inst shl res 3))))
+      (inst shl res n-fixnum-tag-bits))))
 
 (define-vop (digit-ashr)
   (:translate sb!bignum:%ashr)
diff --git a/src/compiler/x86-64/array.lisp b/src/compiler/x86-64/array.lisp
index 6103f2c..26fd1a9 100644
--- a/src/compiler/x86-64/array.lisp
+++ b/src/compiler/x86-64/array.lisp
@@ -30,7 +30,8 @@
   (:node-var node)
   (:generator 13
     (inst lea bytes
-          (make-ea :qword :base rank
+          (make-ea :qword
+                   :index rank :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                    :disp (+ (* (1+ array-dimensions-offset) n-word-bytes)
                             lowtag-mask)))
     (inst and bytes (lognot lowtag-mask))
@@ -38,7 +39,7 @@
                               :disp (fixnumize (1- array-dimensions-offset))))
     (inst shl header n-widetag-bits)
     (inst or  header type)
-    (inst shr header (1- n-lowtag-bits))
+    (inst shr header n-fixnum-tag-bits)
     (pseudo-atomic
      (allocation result bytes node)
      (inst lea result (make-ea :qword :base result :disp other-pointer-lowtag))
@@ -343,23 +344,28 @@
                             complex-offset)
                          other-pointer-lowtag))))))
 
-(define-vop (data-vector-ref-with-offset/simple-array-single-float)
-  (:note "inline array access")
-  (:translate data-vector-ref-with-offset)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-         (index :scs (any-reg)))
-  (:info offset)
-  (:arg-types simple-array-single-float positive-fixnum
-              (:constant (constant-displacement other-pointer-lowtag
-                                                4 vector-data-offset)))
-  (:temporary (:sc unsigned-reg) dword-index)
-  (:results (value :scs (single-reg)))
-  (:result-types single-float)
-  (:generator 5
-   (move dword-index index)
-   (inst shr dword-index 1)
-   (inst movss value (make-ea-for-float-ref object dword-index offset 4))))
+#.
+(let ((use-temp (<= word-shift n-fixnum-tag-bits)))
+  `(define-vop (data-vector-ref-with-offset/simple-array-single-float)
+     (:note "inline array access")
+     (:translate data-vector-ref-with-offset)
+     (:policy :fast-safe)
+     (:args (object :scs (descriptor-reg))
+            (index :scs (any-reg)))
+     (:info offset)
+     (:arg-types simple-array-single-float positive-fixnum
+                 (:constant (constant-displacement other-pointer-lowtag
+                                                   4 vector-data-offset)))
+     ,@(when use-temp '((:temporary (:sc unsigned-reg) dword-index)))
+     (:results (value :scs (single-reg)))
+     (:result-types single-float)
+     (:generator 5
+      ,@(if use-temp
+            '((move dword-index index)
+              (inst shr dword-index (1+ (- n-fixnum-tag-bits word-shift)))
+              (inst movss value (make-ea-for-float-ref object dword-index offset 4)))
+            '((inst movss value (make-ea-for-float-ref object index offset 4
+                                 :scale (ash 4 (- n-fixnum-tag-bits)))))))))
 
 (define-vop (data-vector-ref-c-with-offset/simple-array-single-float)
   (:note "inline array access")
@@ -375,26 +381,31 @@
   (:generator 4
    (inst movss value (make-ea-for-float-ref object index offset 4))))
 
-(define-vop (data-vector-set-with-offset/simple-array-single-float)
-  (:note "inline array store")
-  (:translate data-vector-set-with-offset)
-  (:policy :fast-safe)
-  (:args (object :scs (descriptor-reg))
-         (index :scs (any-reg))
-         (value :scs (single-reg) :target result))
-  (:info offset)
-  (:arg-types simple-array-single-float positive-fixnum
-              (:constant (constant-displacement other-pointer-lowtag
-                                                4 vector-data-offset))
-               single-float)
-  (:temporary (:sc unsigned-reg) dword-index)
-  (:results (result :scs (single-reg)))
-  (:result-types single-float)
-  (:generator 5
-   (move dword-index index)
-   (inst shr dword-index 1)
-   (inst movss (make-ea-for-float-ref object dword-index offset 4) value)
-   (move result value)))
+#.
+(let ((use-temp (<= word-shift n-fixnum-tag-bits)))
+  `(define-vop (data-vector-set-with-offset/simple-array-single-float)
+     (:note "inline array store")
+     (:translate data-vector-set-with-offset)
+     (:policy :fast-safe)
+     (:args (object :scs (descriptor-reg))
+            (index :scs (any-reg))
+            (value :scs (single-reg) :target result))
+     (:info offset)
+     (:arg-types simple-array-single-float positive-fixnum
+                 (:constant (constant-displacement other-pointer-lowtag
+                                                   4 vector-data-offset))
+                  single-float)
+     ,@(when use-temp '((:temporary (:sc unsigned-reg) dword-index)))
+     (:results (result :scs (single-reg)))
+     (:result-types single-float)
+     (:generator 5
+      ,@(if use-temp
+            '((move dword-index index)
+              (inst shr dword-index (1+ (- n-fixnum-tag-bits word-shift)))
+              (inst movss (make-ea-for-float-ref object dword-index offset 4) value))
+            '((inst movss (make-ea-for-float-ref object index offset 4
+                           :scale (ash 4 (- n-fixnum-tag-bits))) value)))
+      (move result value))))
 
 (define-vop (data-vector-set-c-with-offset/simple-array-single-float)
   (:note "inline array store")
@@ -426,7 +437,8 @@
   (:results (value :scs (double-reg)))
   (:result-types double-float)
   (:generator 7
-   (inst movsd value (make-ea-for-float-ref object index offset 8))))
+   (inst movsd value (make-ea-for-float-ref object index offset 8
+                                            :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (data-vector-ref-c/simple-array-double-float)
   (:note "inline array access")
@@ -457,7 +469,9 @@
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 20
-   (inst movsd (make-ea-for-float-ref object index offset 8) value)
+   (inst movsd (make-ea-for-float-ref object index offset 8
+                                      :scale (ash 1 (- word-shift n-fixnum-tag-bits)))
+         value)
    (move result value)))
 
 (define-vop (data-vector-set-c-with-offset/simple-array-double-float)
@@ -493,7 +507,8 @@
   (:results (value :scs (complex-single-reg)))
   (:result-types complex-single-float)
   (:generator 5
-    (inst movq value (make-ea-for-float-ref object index offset 8))))
+    (inst movq value (make-ea-for-float-ref object index offset 8
+                                            :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (data-vector-ref-c-with-offset/simple-array-complex-single-float)
   (:note "inline array access")
@@ -525,7 +540,9 @@
   (:result-types complex-single-float)
   (:generator 5
     (move result value)
-    (inst movq (make-ea-for-float-ref object index offset 8) value)))
+    (inst movq (make-ea-for-float-ref object index offset 8
+                                      :scale (ash 1 (- word-shift n-fixnum-tag-bits)))
+          value)))
 
 (define-vop (data-vector-set-c-with-offset/simple-array-complex-single-float)
   (:note "inline array store")
@@ -557,7 +574,8 @@
   (:results (value :scs (complex-double-reg)))
   (:result-types complex-double-float)
   (:generator 7
-    (inst movapd value (make-ea-for-float-ref object index offset 16 :scale 2))))
+    (inst movapd value (make-ea-for-float-ref object index offset 16
+                                              :scale (ash 2 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (data-vector-ref-c-with-offset/simple-array-complex-double-float)
   (:note "inline array access")
@@ -571,7 +589,7 @@
   (:results (value :scs (complex-double-reg)))
   (:result-types complex-double-float)
   (:generator 6
-    (inst movapd value (make-ea-for-float-ref object index offset 16 :scale 2))))
+    (inst movapd value (make-ea-for-float-ref object index offset 16))))
 
 (define-vop (data-vector-set-with-offset/simple-array-complex-double-float)
   (:note "inline array store")
@@ -588,7 +606,9 @@
   (:results (result :scs (complex-double-reg)))
   (:result-types complex-double-float)
   (:generator 20
-    (inst movapd (make-ea-for-float-ref object index offset 16 :scale 2) value)
+    (inst movapd (make-ea-for-float-ref object index offset 16
+                                        :scale (ash 2 (- word-shift n-fixnum-tag-bits)))
+          value)
     (move result value)))
 
 (define-vop (data-vector-set-c-with-offset/simple-array-complex-double-float)
@@ -605,7 +625,7 @@
   (:results (result :scs (complex-double-reg)))
   (:result-types complex-double-float)
   (:generator 19
-    (inst movapd (make-ea-for-float-ref object index offset 16 :scale 2) value)
+    (inst movapd (make-ea-for-float-ref object index offset 16) value)
     (move result value)))
 
 
diff --git a/src/compiler/x86-64/call.lisp b/src/compiler/x86-64/call.lisp
index b1c5395..e8fdb8a 100644
--- a/src/compiler/x86-64/call.lisp
+++ b/src/compiler/x86-64/call.lisp
@@ -443,7 +443,7 @@
                         :disp (frame-byte-offset
                                (+ sp->fp-offset register-arg-count))))
          ;; Do the copy.
-         (inst shr rcx-tn word-shift)   ; make word count
+         (inst shr rcx-tn n-fixnum-tag-bits)   ; make word count
          (inst std)
          (inst rep)
          (inst movs :qword)
@@ -455,7 +455,7 @@
          ;; If none, then just blow out of here.
          (inst jmp :le restore-edi)
          (inst mov rcx-tn rax-tn)
-         (inst shr rcx-tn word-shift)   ; word count
+         (inst shr rcx-tn n-fixnum-tag-bits)   ; word count
          ;; Load RAX with NIL for fast storing.
          (inst mov rax-tn nil-value)
          ;; Do the store.
@@ -510,7 +510,15 @@
               register-arg-count)
       (inst cmp nargs (fixnumize register-arg-count))
       (inst jmp :g stack-values)
+      #!+#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or))
       (inst sub rsp-tn nargs)
+      #!-#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or))
+      (progn
+        ;; FIXME: This can't be efficient, but LEA (my first choice)
+        ;; doesn't do subtraction.
+        (inst shl nargs (- word-shift n-fixnum-tag-bits))
+        (inst sub rsp-tn nargs)
+        (inst shr nargs (- word-shift n-fixnum-tag-bits)))
       (emit-label stack-values))
     ;; dtc: this writes the registers onto the stack even if they are
     ;; not needed, only the number specified in rcx are used and have
@@ -810,6 +818,9 @@
                               ;; Compute the number of arguments.
                               (noise '(inst mov rcx new-fp))
                               (noise '(inst sub rcx rsp-tn))
+                              #.(unless (= word-shift n-fixnum-tag-bits)
+                                  '(noise '(inst shr rcx
+                                            (- word-shift n-fixnum-tag-bits))))
                               ;; Move the necessary args to registers,
                               ;; this moves them all even if they are
                               ;; not all needed.
@@ -874,11 +885,11 @@
                           ;; there are at least 3 slots. This hack
                           ;; just adds 3 more.
                           ,(if variable
-                               '(inst sub rsp-tn (fixnumize 3)))
+                               '(inst sub rsp-tn (* 3 n-word-bytes)))
 
                           ;; Bias the new-fp for use as an fp
                           ,(if variable
-                               '(inst sub new-fp (fixnumize sp->fp-offset)))
+                               '(inst sub new-fp (* sp->fp-offset n-word-bytes)))
 
                           ;; Save the fp
                           (storew rbp-tn new-fp
@@ -1128,15 +1139,19 @@
            (inst cmp rcx-tn (fixnumize fixed))
            (inst jmp :be JUST-ALLOC-FRAME)))
 
+    ;; Create a negated copy of the number of arguments to allow us to
+    ;; use EA calculations in order to do scaled subtraction.
+    (inst mov temp rcx-tn)
+    (inst neg temp)
+
     ;; Allocate the space on the stack.
     ;; stack = rbp + sp->fp-offset - (max 3 frame-size) - (nargs - fixed)
-    (inst lea rbx-tn
+    (inst lea rsp-tn
           (make-ea :qword :base rbp-tn
+                   :index temp :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                    :disp (* n-word-bytes
                             (- (+ sp->fp-offset fixed)
                                (max 3 (sb-allocated-size 'stack))))))
-    (inst sub rbx-tn rcx-tn)  ; Got the new stack in rbx
-    (inst mov rsp-tn rbx-tn)
 
     ;; Now: nargs>=1 && nargs>fixed
 
@@ -1156,8 +1171,8 @@
 
     ;; Initialize R8 to be the end of args.
     (inst lea source (make-ea :qword :base rbp-tn
+                              :index temp :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                               :disp (* sp->fp-offset n-word-bytes)))
-    (inst sub source rbx-tn)
 
     ;; We need to copy from downwards up to avoid overwriting some of
     ;; the yet uncopied args. So we need to use R9 as the copy index
@@ -1170,7 +1185,7 @@
     (inst mov temp (make-ea :qword :base source :index copy-index))
     (inst mov (make-ea :qword :base rsp-tn :index copy-index) temp)
     (inst add copy-index n-word-bytes)
-    (inst sub rcx-tn n-word-bytes)
+    (inst sub rcx-tn (fixnumize 1))
     (inst jmp :nz COPY-LOOP)
 
     DO-REGS
@@ -1225,8 +1240,10 @@
             (keyword :scs (descriptor-reg any-reg)))
   (:result-types * *)
   (:generator 4
-     (inst mov value (make-ea :qword :base object :index index))
+     (inst mov value (make-ea :qword :base object :index index
+                              :scale (ash 1 (- word-shift n-fixnum-tag-bits))))
      (inst mov keyword (make-ea :qword :base object :index index
+                                :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                 :disp n-word-bytes))))
 
 (define-vop (more-arg)
@@ -1240,7 +1257,8 @@
   (:generator 4
     (move value index)
     (inst neg value)
-    (inst mov value (make-ea :qword :base object :index value))))
+    (inst mov value (make-ea :qword :base object :index value
+                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 ;;; Turn more arg (context, count) into a list.
 (define-vop (listify-rest-args)
@@ -1265,7 +1283,7 @@
       ;; Check to see whether there are no args, and just return NIL if so.
       (inst mov result nil-value)
       (inst jrcxz done)
-      (inst lea dst (make-ea :qword :base rcx :index rcx))
+      (inst lea dst (make-ea :qword :index rcx :scale (ash 2 (- word-shift n-fixnum-tag-bits))))
       (maybe-pseudo-atomic stack-allocate-p
        (allocation dst dst node stack-allocate-p list-pointer-lowtag)
        ;; Set decrement mode (successive args at lower addresses)
@@ -1286,7 +1304,7 @@
        (inst sub src n-word-bytes)
        (storew rax dst 0 list-pointer-lowtag)
        ;; Go back for more.
-       (inst sub rcx n-word-bytes)
+       (inst sub rcx (fixnumize 1))
        (inst jmp :nz loop)
        ;; NIL out the last cons.
        (storew nil-value dst 1 list-pointer-lowtag)
@@ -1318,8 +1336,9 @@
     ;; SP at this point points at the last arg pushed.
     ;; Point to the first more-arg, not above it.
     (inst lea context (make-ea :qword :base rsp-tn
-                               :index count :scale 1
-                               :disp (- (+ (fixnumize fixed) n-word-bytes))))
+                               :index count
+                               :scale (ash 1 (- word-shift n-fixnum-tag-bits))
+                               :disp (- (* (1+ fixed) n-word-bytes))))
     (unless (zerop fixed)
       (inst sub count (fixnumize fixed)))))
 
diff --git a/src/compiler/x86-64/cell.lisp b/src/compiler/x86-64/cell.lisp
index 0857ff6..a27dc19 100644
--- a/src/compiler/x86-64/cell.lisp
+++ b/src/compiler/x86-64/cell.lisp
@@ -239,7 +239,7 @@
     ;; it is a fixnum.  The lowtag selection magic that is required to
     ;; ensure this is explained in the comment in objdef.lisp
     (loadw res symbol symbol-hash-slot other-pointer-lowtag)
-    (inst and res (lognot #b111))))
+    (inst and res (lognot fixnum-tag-mask))))
 
 ;;;; fdefinition (FDEFN) objects
 
@@ -502,8 +502,8 @@
 
 ;;;; raw instance slot accessors
 
-(defun make-ea-for-raw-slot (object index instance-length
-                             &optional (adjustment 0))
+(defun make-ea-for-raw-slot (object instance-length
+                             &key (index nil) (adjustment 0) (scale 1))
   (if (integerp instance-length)
       ;; For RAW-INSTANCE-INIT/* VOPs, which know the exact instance length
       ;; at compile time.
@@ -514,8 +514,8 @@
                         (- instance-pointer-lowtag)
                         adjustment))
       (etypecase index
-        (tn
-         (make-ea :qword :base object :index instance-length
+        (null
+         (make-ea :qword :base object :index instance-length :scale scale
                   :disp (+ (* (1- instance-slots-offset) n-word-bytes)
                            (- instance-pointer-lowtag)
                            adjustment)))
@@ -540,7 +540,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst mov value (make-ea-for-raw-slot object index tmp))))
+    (inst mov value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (raw-instance-ref-c/word)
   (:translate %raw-instance-ref/word)
@@ -556,7 +556,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst mov value (make-ea-for-raw-slot object index tmp))))
+    (inst mov value (make-ea-for-raw-slot object tmp :index index))))
 
 (define-vop (raw-instance-set/word)
   (:translate %raw-instance-set/word)
@@ -573,7 +573,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst mov (make-ea-for-raw-slot object index tmp) value)
+    (inst mov (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
     (move result value)))
 
 (define-vop (raw-instance-set-c/word)
@@ -592,7 +592,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst mov (make-ea-for-raw-slot object index tmp) value)
+    (inst mov (make-ea-for-raw-slot object tmp :index index) value)
     (move result value)))
 
 (define-vop (raw-instance-init/word)
@@ -601,7 +601,7 @@
   (:arg-types * unsigned-num)
   (:info instance-length index)
   (:generator 4
-    (inst mov (make-ea-for-raw-slot object index instance-length) value)))
+    (inst mov (make-ea-for-raw-slot object instance-length :index index) value)))
 
 (define-vop (raw-instance-atomic-incf-c/word)
   (:translate %raw-instance-atomic-incf/word)
@@ -619,7 +619,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst xadd (make-ea-for-raw-slot object index tmp) diff :lock)
+    (inst xadd (make-ea-for-raw-slot object tmp :index index) diff :lock)
     (move result diff)))
 
 (define-vop (raw-instance-ref/single)
@@ -636,7 +636,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst movss value (make-ea-for-raw-slot object index tmp))))
+    (inst movss value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (raw-instance-ref-c/single)
   (:translate %raw-instance-ref/single)
@@ -652,7 +652,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst movss value (make-ea-for-raw-slot object index tmp))))
+    (inst movss value (make-ea-for-raw-slot object tmp :index index))))
 
 (define-vop (raw-instance-set/single)
   (:translate %raw-instance-set/single)
@@ -669,7 +669,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst movss (make-ea-for-raw-slot object index tmp) value)
+    (inst movss (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
     (move result value)))
 
 (define-vop (raw-instance-set-c/single)
@@ -688,7 +688,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst movss (make-ea-for-raw-slot object index tmp) value)
+    (inst movss (make-ea-for-raw-slot object tmp :index index) value)
     (move result value)))
 
 (define-vop (raw-instance-init/single)
@@ -697,7 +697,7 @@
   (:arg-types * single-float)
   (:info instance-length index)
   (:generator 4
-    (inst movss (make-ea-for-raw-slot object index instance-length) value)))
+    (inst movss (make-ea-for-raw-slot object instance-length :index index) value)))
 
 (define-vop (raw-instance-ref/double)
   (:translate %raw-instance-ref/double)
@@ -713,7 +713,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst movsd value (make-ea-for-raw-slot object index tmp))))
+    (inst movsd value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (raw-instance-ref-c/double)
   (:translate %raw-instance-ref/double)
@@ -729,7 +729,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst movsd value (make-ea-for-raw-slot object index tmp))))
+    (inst movsd value (make-ea-for-raw-slot object tmp :index index))))
 
 (define-vop (raw-instance-set/double)
   (:translate %raw-instance-set/double)
@@ -746,7 +746,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst movsd (make-ea-for-raw-slot object index tmp) value)
+    (inst movsd (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)
     (move result value)))
 
 (define-vop (raw-instance-set-c/double)
@@ -765,7 +765,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst movsd (make-ea-for-raw-slot object index tmp) value)
+    (inst movsd (make-ea-for-raw-slot object tmp :index index) value)
     (move result value)))
 
 (define-vop (raw-instance-init/double)
@@ -774,7 +774,7 @@
   (:arg-types * double-float)
   (:info instance-length index)
   (:generator 4
-    (inst movsd (make-ea-for-raw-slot object index instance-length) value)))
+    (inst movsd (make-ea-for-raw-slot object instance-length :index index) value)))
 
 (define-vop (raw-instance-ref/complex-single)
   (:translate %raw-instance-ref/complex-single)
@@ -790,7 +790,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst movq value (make-ea-for-raw-slot object index tmp))))
+    (inst movq value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (raw-instance-ref-c/complex-single)
   (:translate %raw-instance-ref/complex-single)
@@ -806,7 +806,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst movq value (make-ea-for-raw-slot object index tmp))))
+    (inst movq value (make-ea-for-raw-slot object tmp :index index))))
 
 (define-vop (raw-instance-set/complex-single)
   (:translate %raw-instance-set/complex-single)
@@ -824,7 +824,7 @@
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (move result value)
-    (inst movq (make-ea-for-raw-slot object index tmp) value)))
+    (inst movq (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits))) value)))
 
 (define-vop (raw-instance-set-c/complex-single)
   (:translate %raw-instance-set/complex-single)
@@ -843,7 +843,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (move result value)
-    (inst movq (make-ea-for-raw-slot object index tmp) value)))
+    (inst movq (make-ea-for-raw-slot object tmp :index index) value)))
 
 (define-vop (raw-instance-init/complex-single)
   (:args (object :scs (descriptor-reg))
@@ -851,7 +851,7 @@
   (:arg-types * complex-single-float)
   (:info instance-length index)
   (:generator 4
-    (inst movq (make-ea-for-raw-slot object index instance-length) value)))
+    (inst movq (make-ea-for-raw-slot object instance-length :index index) value)))
 
 (define-vop (raw-instance-ref/complex-double)
   (:translate %raw-instance-ref/complex-double)
@@ -867,7 +867,7 @@
     (inst shr tmp n-widetag-bits)
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
-    (inst movdqu value (make-ea-for-raw-slot object index tmp -8))))
+    (inst movdqu value (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8))))
 
 (define-vop (raw-instance-ref-c/complex-double)
   (:translate %raw-instance-ref/complex-double)
@@ -883,7 +883,7 @@
   (:generator 4
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst movdqu value (make-ea-for-raw-slot object index tmp -8))))
+    (inst movdqu value (make-ea-for-raw-slot object tmp :index index :adjustment -8))))
 
 (define-vop (raw-instance-set/complex-double)
   (:translate %raw-instance-set/complex-double)
@@ -901,7 +901,7 @@
     (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (move result value)
-    (inst movdqu (make-ea-for-raw-slot object index tmp -8) value)))
+    (inst movdqu (make-ea-for-raw-slot object tmp :scale (ash 1 (- word-shift n-fixnum-tag-bits)) :adjustment -8) value)))
 
 (define-vop (raw-instance-set-c/complex-double)
   (:translate %raw-instance-set/complex-double)
@@ -920,7 +920,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (move result value)
-    (inst movdqu (make-ea-for-raw-slot object index tmp -8) value)))
+    (inst movdqu (make-ea-for-raw-slot object tmp :index index :adjustment -8) value)))
 
 (define-vop (raw-instance-init/complex-double)
   (:args (object :scs (descriptor-reg))
@@ -928,4 +928,4 @@
   (:arg-types * complex-double-float)
   (:info instance-length index)
   (:generator 4
-    (inst movdqu (make-ea-for-raw-slot object index instance-length -8) value)))
+    (inst movdqu (make-ea-for-raw-slot object instance-length :index index :adjustment -8) value)))
diff --git a/src/compiler/x86-64/debug.lisp b/src/compiler/x86-64/debug.lisp
index 5f720fe..ef6e0e2 100644
--- a/src/compiler/x86-64/debug.lisp
+++ b/src/compiler/x86-64/debug.lisp
@@ -43,7 +43,8 @@
     (move temp offset)
     (inst neg temp)
     (inst mov result
-          (make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp))))
+          (make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp
+                   :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 
 (define-vop (read-control-stack-c)
   (:translate stack-ref)
@@ -71,7 +72,8 @@
     (move temp offset)
     (inst neg temp)
     (inst mov
-          (make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp)
+          (make-ea :qword :base sap :disp (frame-byte-offset 0) :index temp
+                   :scale (ash 1 (- word-shift n-fixnum-tag-bits)))
           value)
     (move result value)))
 
diff --git a/src/compiler/x86-64/macros.lisp b/src/compiler/x86-64/macros.lisp
index b7b0aa9..b7d0ef4 100644
--- a/src/compiler/x86-64/macros.lisp
+++ b/src/compiler/x86-64/macros.lisp
@@ -362,6 +362,7 @@
        (:generator 5
          (move rax old-value)
          (inst cmpxchg (make-ea :qword :base object :index index
+                                :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                 :disp (- (* ,offset n-word-bytes) ,lowtag))
                new-value :lock)
          (move value rax)))))
@@ -379,6 +380,7 @@
        (:result-types ,el-type)
        (:generator 3                    ; pw was 5
          (inst mov value (make-ea :qword :base object :index index
+                                  :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                   :disp (- (* ,offset n-word-bytes)
                                            ,lowtag)))))
      (define-vop (,(symbolicate name "-C"))
@@ -413,6 +415,7 @@
        (:result-types ,el-type)
        (:generator 3                    ; pw was 5
          (inst mov value (make-ea :qword :base object :index index
+                                  :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                                   :disp (- (* (+ ,offset offset) n-word-bytes)
                                            ,lowtag)))))
      (define-vop (,(symbolicate name "-C"))
@@ -447,6 +450,7 @@
        (:result-types ,el-type)
        (:generator 4                    ; was 5
          (inst mov (make-ea :qword :base object :index index
+                            :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                             :disp (- (* ,offset n-word-bytes) ,lowtag))
                value)
          (move result value)))
@@ -489,6 +493,7 @@
        (:result-types ,el-type)
        (:generator 4                    ; was 5
          (inst mov (make-ea :qword :base object :index index
+                            :scale (ash 1 (- word-shift n-fixnum-tag-bits))
                             :disp (- (* (+ ,offset offset) n-word-bytes) ,lowtag))
                value)
          (move result value)))
diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp
index be974f2..1b084d0 100644
--- a/src/compiler/x86-64/move.lisp
+++ b/src/compiler/x86-64/move.lisp
@@ -347,7 +347,8 @@
   (:generator 20
     (aver (not (location= x y)))
     (let ((done (gen-label)))
-      (inst mov y #.(ash lowtag-mask n-positive-fixnum-bits))
+      (inst mov y #.(ash (1- (ash 1 (1+ n-fixnum-tag-bits)))
+                         n-positive-fixnum-bits))
       ;; The assembly routines test the sign flag from this one, so if
       ;; you change stuff here, make sure the sign flag doesn't get
       ;; overwritten before the CALL!
diff --git a/src/compiler/x86-64/nlx.lisp b/src/compiler/x86-64/nlx.lisp
index 4cc02fd..b7b3e70 100644
--- a/src/compiler/x86-64/nlx.lisp
+++ b/src/compiler/x86-64/nlx.lisp
@@ -212,7 +212,7 @@
     (inst sub rdi n-word-bytes)
     (move rcx count)                    ; fixnum words == bytes
     (move num rcx)
-    (inst shr rcx word-shift)           ; word count for <rep movs>
+    (inst shr rcx n-fixnum-tag-bits)    ; word count for <rep movs>
     ;; If we got zero, we be done.
     (inst jrcxz DONE)
     ;; Copy them down.
diff --git a/src/compiler/x86-64/static-fn.lisp b/src/compiler/x86-64/static-fn.lisp
index 02ae35b..8760e33 100644
--- a/src/compiler/x86-64/static-fn.lisp
+++ b/src/compiler/x86-64/static-fn.lisp
@@ -79,7 +79,7 @@
          ;; effect of the ENTER with discrete instructions. Takes
          ;; 3+4+4=11 bytes as opposed to 1+4=5 bytes.
          (cond ((policy ,node (>= speed space))
-                (inst sub rsp-tn (fixnumize 3))
+                (inst sub rsp-tn (* 3 n-word-bytes))
                 (inst mov (make-ea :qword :base rsp-tn
                                    :disp (frame-byte-offset
                                           (+ sp->fp-offset
@@ -94,7 +94,7 @@
                (t
                 ;; Dummy for return address.
                 (inst push rbp-tn)
-                (inst enter (fixnumize 1))))
+                (inst enter n-word-bytes)))
 
          ,(if (zerop num-args)
               '(inst xor ecx ecx)
diff --git a/src/compiler/x86-64/system.lisp b/src/compiler/x86-64/system.lisp
index 2d710d9..7cb54a4 100644
--- a/src/compiler/x86-64/system.lisp
+++ b/src/compiler/x86-64/system.lisp
@@ -39,14 +39,14 @@
     (inst cmp al-tn fun-pointer-lowtag)
     (inst jmp :e FUNCTION-PTR)
 
-    ;; Pick off structures and list pointers.
-    (inst test al-tn 1)
-    (inst jmp :ne DONE)
-
     ;; Pick off fixnums.
-    (inst and al-tn fixnum-tag-mask)
+    (inst test al-tn fixnum-tag-mask)
     (inst jmp :e DONE)
 
+    ;; Pick off structures and list pointers.
+    (inst test al-tn 2)
+    (inst jmp :ne DONE)
+
     ;; must be an other immediate
     (inst mov rax object)
     (inst jmp DONE)
diff --git a/src/compiler/x86-64/values.lisp b/src/compiler/x86-64/values.lisp
index 05b00d6..0ea0535 100644
--- a/src/compiler/x86-64/values.lisp
+++ b/src/compiler/x86-64/values.lisp
@@ -97,7 +97,9 @@
 
     DONE
     (inst mov count start)              ; start is high address
-    (inst sub count rsp-tn)))           ; stackp is low address
+    (inst sub count rsp-tn)             ; stackp is low address
+    #!-#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or))
+    (inst shr count (- word-shift n-fixnum-tag-bits))))
 
 ;;; Copy the more arg block to the top of the stack so we can use them
 ;;; as function arguments.
@@ -132,16 +134,25 @@
 
       (any-reg
        (move src context)
+       #!+#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or))
        (inst sub src skip)
+       #!-#.(cl:if (cl:= sb!vm:word-shift sb!vm:n-fixnum-tag-bits) '(and) '(or))
+       (progn
+         ;; FIXME: This can't be efficient, but LEA (my first choice)
+         ;; doesn't do subtraction.
+         (inst shl skip (- word-shift n-fixnum-tag-bits))
+         (inst sub src skip)
+         (inst shr skip (- word-shift n-fixnum-tag-bits)))
        (move count num)
        (inst sub count skip)))
 
-    (move loop-index count)
+    (inst lea loop-index (make-ea :byte :index count
+                                  :scale (ash 1 (- word-shift n-fixnum-tag-bits))))
     (inst mov start rsp-tn)
     (inst jrcxz DONE)  ; check for 0 count?
 
-    (inst sub rsp-tn count)
-    (inst sub src count)
+    (inst sub rsp-tn loop-index)
+    (inst sub src loop-index)
 
     LOOP
     (inst mov temp (make-ea :qword :base src :index loop-index))
diff --git a/src/runtime/x86-64-assem.S b/src/runtime/x86-64-assem.S
index c29aceb..e2bc331 100644
--- a/src/runtime/x86-64-assem.S
+++ b/src/runtime/x86-64-assem.S
@@ -194,7 +194,7 @@ Lstack:
 	xor	%rdx,%rdx	# clear any descriptor registers 
 	xor	%rdi,%rdi	# that we can't be sure we'll 
 	xor	%rsi,%rsi	# initialise properly.  XX do r8-r15 too?
-	shl	$3,%rcx		# (fixnumize num-args)
+	shl	$N_FIXNUM_TAG_BITS,%rcx	# (fixnumize num-args)
 	cmp	$0,%rcx
 	je	Ldone
 	mov	0(%rbx),%rdx	# arg0