[Sbcl-commits] CVS: sbcl/src/compiler/x86 arith.lisp, 1.48, 1.49 array.lisp, 1.24, 1.25 macros.lisp, 1.37, 1.38 parms.lisp, 1.65, 1.66 sap.lisp, 1.10, 1.11

[Nathan F. <nf...@us...>]

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12188/src/compiler/x86

Modified Files:
	arith.lisp array.lisp macros.lisp parms.lisp sap.lisp 
Log Message:
1.0.2.1: DATA-VECTOR-{REF,SET}-WITH-OFFSET for the x86

	Compile calls of (AREF FOO (+ INDEX <constant>) more efficiently:
	... turn DATA-VECTOR-{REF,SET} into
	  DATA-VECTOR-{REF,SET}-WITH-OFFSET when the element type of FOO
	  is at least 8 bits wide;
	... introduce general mechanism for optimization of such calls;
	... redo the x86 DATA-VECTOR-FOO VOPs, reducing the number of such
	  VOPs in the process;
	... do the same for BIGNUM-REF and SAP-REF-FOO.

	Upshot: 5-10% increase in performance on array-heavy code such
	  as Ironclad; a 20% increase in performance has been observed
	  on cellular automata codes.  Some restrictions apply; see the
	  KLUDGE in src/compiler/generic/vm-tran for an example.


Index: arith.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/arith.lisp,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -d -r1.48 -r1.49
--- arith.lisp	17 Sep 2006 02:31:13 -0000	1.48
+++ arith.lisp	27 Jan 2007 03:45:49 -0000	1.49
@@ -1476,7 +1476,9 @@
 
 (define-full-reffer bignum-ref * bignum-digits-offset other-pointer-lowtag
   (unsigned-reg) unsigned-num sb!bignum:%bignum-ref)
-
+(define-full-reffer+offset bignum-ref-with-offset *
+  bignum-digits-offset other-pointer-lowtag
+  (unsigned-reg) unsigned-num sb!bignum:%bignum-ref-with-offset)
 (define-full-setter bignum-set * bignum-digits-offset other-pointer-lowtag
   (unsigned-reg) unsigned-num sb!bignum:%bignum-set)
 

Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/array.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- array.lisp	15 Jul 2006 04:26:24 -0000	1.24
+++ array.lisp	27 Jan 2007 03:45:50 -0000	1.25
@@ -132,12 +132,12 @@
 ;;; out of 8, 16, or 32 bit elements.
 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
              `(progn
-                (define-full-reffer ,(symbolicate "DATA-VECTOR-REF/" type)
+                (define-full-reffer+offset ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type)
                   ,type vector-data-offset other-pointer-lowtag ,scs
-                  ,element-type data-vector-ref)
-                (define-full-setter ,(symbolicate "DATA-VECTOR-SET/" type)
+                  ,element-type data-vector-ref-with-offset)
+                (define-full-setter+offset ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" type)
                   ,type vector-data-offset other-pointer-lowtag ,scs
[...1160 lines suppressed...]
-         (value :scs (signed-reg) :target eax))
-  (:info index)
-  (:arg-types simple-array-signed-byte-16 (:constant (signed-byte 30)) tagged-num)
-  (:temporary (:sc signed-reg :offset eax-offset :target result
-                   :from (:argument 1) :to (:result 0))
-              eax)
-  (:results (result :scs (signed-reg)))
-  (:result-types tagged-num)
-  (:generator 4
-    (move eax value)
-    (inst mov
-          (make-ea :word :base object
-                   :disp (- (+ (* vector-data-offset n-word-bytes)
-                               (* 2 index))
-                            other-pointer-lowtag))
-          ax-tn)
-    (move result eax)))
 
 ;;; These vops are useful for accessing the bits of a vector
 ;;; irrespective of what type of vector it is.

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/macros.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- macros.lisp	5 Dec 2006 21:34:06 -0000	1.37
+++ macros.lisp	27 Jan 2007 03:45:50 -0000	1.38
@@ -393,7 +393,7 @@
            `((:translate ,translate)))
        (:policy :fast-safe)
        (:args (object :scs (descriptor-reg))
-              (index :scs (any-reg immediate)))
+              (index :scs (any-reg immediate unsigned-reg)))
        (:arg-types ,type tagged-num)
        (:results (value :scs ,scs))
        (:result-types ,el-type)
@@ -404,11 +404,50 @@
                                      :disp (- (* (+ ,offset (tn-value index))
                                                  n-word-bytes)
                                               ,lowtag))))
+           (unsigned-reg
+            (inst mov value (make-ea :dword :base object :index index :scale 4
+                                     :disp (- (* ,offset n-word-bytes)
+                                              ,lowtag))))
            (t
             (inst mov value (make-ea :dword :base object :index index
                                      :disp (- (* ,offset n-word-bytes)
                                               ,lowtag)))))))))
 
+(defmacro define-full-reffer+offset (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+           `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+              (index :scs (any-reg immediate unsigned-reg)))
+       (:arg-types ,type tagged-num
+                   (:constant (constant-displacement ,lowtag sb!vm:n-word-bytes ,offset)))
+       (:info offset)
+       (:results (value :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 3                    ; pw was 5
+         (unless (zerop offset)
+           (format t "Attempting D-F-R-O, offset ~D~%" offset))
+         (sc-case index
+           (immediate
+            (inst mov value (make-ea :dword :base object
+                                     :disp (- (* (+ ,offset
+                                                    (tn-value index)
+                                                    offset)
+                                                 n-word-bytes)
+                                              ,lowtag))))
+           (unsigned-reg
+            (inst mov value (make-ea :dword :base object :index index :scale 4
+                                     :disp (- (* (+ ,offset offset)
+                                                 n-word-bytes)
+                                              ,lowtag))))
+           (t
+            (inst mov value (make-ea :dword :base object :index index
+                                     :disp (- (* (+ ,offset offset)
+                                                 n-word-bytes)
+                                              ,lowtag)))))))))
+
 (defmacro define-full-setter (name type offset lowtag scs el-type &optional translate)
   `(progn
      (define-vop (,name)
@@ -435,6 +474,35 @@
                   value)))
         (move result value)))))
 
+(defmacro define-full-setter+offset (name type offset lowtag scs el-type &optional translate)
+  `(progn
+     (define-vop (,name)
+       ,@(when translate
+           `((:translate ,translate)))
+       (:policy :fast-safe)
+       (:args (object :scs (descriptor-reg))
+              (index :scs (any-reg immediate))
+              (value :scs ,scs :target result))
+       (:info offset)
+       (:arg-types ,type tagged-num
+                   (:constant (constant-displacement ,lowtag sb!vm:n-word-bytes ,offset)) ,el-type)
+       (:results (result :scs ,scs))
+       (:result-types ,el-type)
+       (:generator 4                    ; was 5
+         (sc-case index
+           (immediate
+            (inst mov (make-ea :dword :base object
+                               :disp (- (* (+ ,offset (tn-value index) offset)
+                                           n-word-bytes)
+                                        ,lowtag))
+                  value))
+           (t
+            (inst mov (make-ea :dword :base object :index index
+                               :disp (- (* (+ ,offset offset)
+                                           n-word-bytes) ,lowtag))
+                  value)))
+        (move result value)))))
+
 ;;; helper for alien stuff.
 (defmacro with-pinned-objects ((&rest objects) &body body)
   "Arrange with the garbage collector that the pages occupied by

Index: parms.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/parms.lisp,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -d -r1.65 -r1.66
--- parms.lisp	15 Jan 2007 22:15:49 -0000	1.65
+++ parms.lisp	27 Jan 2007 03:45:50 -0000	1.66
@@ -35,6 +35,12 @@
 ;;; addressable object
 (def!constant n-byte-bits 8)
 
+;;; The minimum immediate offset in a memory-referencing instruction.
+(def!constant minimum-immediate-offset (- (expt 2 31)))
+
+;;; The maximum immediate offset in a memory-referencing instruction.
+(def!constant maximum-immediate-offset (1- (expt 2 31)))
+
 (def!constant float-sign-shift 31)
 
 ;;; comment from CMU CL:

Index: sap.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/sap.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- sap.lisp	28 May 2006 03:25:51 -0000	1.10
+++ sap.lisp	27 Jan 2007 03:45:50 -0000	1.11
@@ -150,16 +150,22 @@
                                     type
                                     size
                                     &optional signed)
-             (let ((ref-name-c (symbolicate ref-name "-C"))
-                   (set-name-c (symbolicate set-name "-C"))
-                   (temp-sc (symbolicate size "-REG")))
+             (let ((temp-sc (symbolicate size "-REG"))
+                   (element-size (ecase size
+                                   (:byte 1)
+                                   (:word 2)
+                                   (:dword 4))))
                `(progn
                   (define-vop (,ref-name)
                     (:translate ,ref-name)
                     (:policy :fast-safe)
                     (:args (sap :scs (sap-reg))
                            (offset :scs (signed-reg immediate)))
-                    (:arg-types system-area-pointer signed-num)
+                    (:info disp)
+                    (:arg-types system-area-pointer signed-num
+                                (:constant (constant-displacement 0 ; lowtag
+                                                                  ,element-size
+                                                                  0)))
                     (:results (result :scs (,sc)))
                     (:result-types ,type)
                     (:generator 5
@@ -171,10 +177,12 @@
                             (immediate
                              (inst ,mov-inst result
                                    (make-ea ,size :base sap
-                                            :disp (tn-value offset))))
+                                            :disp (+ (tn-value offset)
+                                                     (* ,element-size disp)))))
                             (t (inst ,mov-inst result
                                      (make-ea ,size :base sap
-                                              :index offset)))))))
+                                              :index offset
+                                              :disp (* ,element-size disp))))))))
                   (define-vop (,set-name)
                     (:translate ,set-name)
                     (:policy :fast-safe)
@@ -184,7 +192,12 @@
                                   :target ,(if (eq size :dword)
                                                'result
                                                'temp)))
-                    (:arg-types system-area-pointer signed-num ,type)
+                    (:info disp)
+                    (:arg-types system-area-pointer signed-num
+                                (:constant (constant-displacement 0 ; lowtag
+                                                                  ,element-size
+                                                                  0))
+                                ,type)
                     ,@(unless (eq size :dword)
                         `((:temporary (:sc ,temp-sc :offset eax-offset
                                            :from (:argument 2) :to (:result 0)
@@ -193,105 +206,118 @@
                     (:results (result :scs (,sc)))
                     (:result-types ,type)
                     (:generator 5
-                                ,@(unless (eq size :dword)
-                                    `((move eax-tn value)))
-                                (inst mov (sc-case offset
-                                            (immediate
-                                             (make-ea ,size :base sap
-                                                      :disp (tn-value offset)))
-                                            (t (make-ea ,size
-                                                        :base sap
-                                                        :index offset)))
-                                      ,(if (eq size :dword) 'value 'temp))
-                                (move result
-                                      ,(if (eq size :dword) 'value 'eax-tn))))))))
+                      ,@(unless (eq size :dword)
+                          `((move eax-tn value)))
+                      (inst mov (sc-case offset
+                                         (immediate
+                                          (make-ea ,size :base sap
+                                                   :disp (+ (tn-value offset)
+                                                            (* ,element-size disp))))
+                                         (t (make-ea ,size
+                                                     :base sap
+                                                     :index offset
+                                                     :disp (* ,element-size disp))))
+                            ,(if (eq size :dword) 'value 'temp))
+                      (move result
+                            ,(if (eq size :dword) 'value 'eax-tn))))))))
 
-  (def-system-ref-and-set sap-ref-8 %set-sap-ref-8
+  (def-system-ref-and-set sb!c::sap-ref-8-with-offset sb!c::%set-sap-ref-8-with-offset
     unsigned-reg positive-fixnum :byte nil)
-  (def-system-ref-and-set signed-sap-ref-8 %set-signed-sap-ref-8
+  (def-system-ref-and-set sb!c::signed-sap-ref-8-with-offset sb!c::%set-signed-sap-ref-8-with-offset
     signed-reg tagged-num :byte t)
-  (def-system-ref-and-set sap-ref-16 %set-sap-ref-16
+  (def-system-ref-and-set sb!c::sap-ref-16-with-offset sb!c::%set-sap-ref-16-with-offset
     unsigned-reg positive-fixnum :word nil)
-  (def-system-ref-and-set signed-sap-ref-16 %set-signed-sap-ref-16
+  (def-system-ref-and-set sb!c::signed-sap-ref-16-with-offset sb!c::%set-signed-sap-ref-16-with-offset
     signed-reg tagged-num :word t)
-  (def-system-ref-and-set sap-ref-32 %set-sap-ref-32
+  (def-system-ref-and-set sb!c::sap-ref-32-with-offset sb!c::%set-sap-ref-32-with-offset
     unsigned-reg unsigned-num :dword nil)
-  (def-system-ref-and-set signed-sap-ref-32 %set-signed-sap-ref-32
+  (def-system-ref-and-set sb!c::signed-sap-ref-32-with-offset sb!c::%set-signed-sap-ref-32-with-offset
     signed-reg signed-num :dword t)
-  (def-system-ref-and-set sap-ref-sap %set-sap-ref-sap
+  (def-system-ref-and-set sb!c::sap-ref-sap-with-offset sb!c::%set-sap-ref-sap-with-offset
     sap-reg system-area-pointer :dword))
 
 ;;;; SAP-REF-DOUBLE
 
-(define-vop (sap-ref-double)
-  (:translate sap-ref-double)
+(define-vop (sap-ref-double-with-offset)
+  (:translate sb!c::sap-ref-double-with-offset)
   (:policy :fast-safe)
   (:args (sap :scs (sap-reg))
-         (offset :scs (signed-reg)))
-  (:arg-types system-area-pointer signed-num)
+         (offset :scs (signed-reg immediate)))
+  (:info disp)
+  (:arg-types system-area-pointer signed-num
+              (:constant (constant-displacement 0 ; lowtag
+                                                8 ; double-float size
+                                                0)))
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 5
-     (with-empty-tn@fp-top(result)
-        (inst fldd (make-ea :dword :base sap :index offset)))))
-
-(define-vop (sap-ref-double-c)
-  (:translate sap-ref-double)
-  (:policy :fast-safe)
-  (:args (sap :scs (sap-reg)))
-  (:arg-types system-area-pointer (:constant (signed-byte 32)))
-  (:info offset)
-  (:results (result :scs (double-reg)))
-  (:result-types double-float)
-  (:generator 4
-     (with-empty-tn@fp-top(result)
-        (inst fldd (make-ea :dword :base sap :disp offset)))))
+     (sc-case offset
+       (immediate
+        (aver (zerop disp))
+        (with-empty-tn@fp-top(result)
+          (inst fldd (make-ea :dword :base sap :disp (tn-value offset)))))
+       (t
+        (with-empty-tn@fp-top(result)
+          (inst fldd (make-ea :dword :base sap :index offset
+                              :disp (* 4 disp))))))))
 
-(define-vop (%set-sap-ref-double)
-  (:translate %set-sap-ref-double)
+(define-vop (%set-sap-ref-double-with-offset)
+  (:translate sb!c::%set-sap-ref-double-with-offset)
   (:policy :fast-safe)
   (:args (sap :scs (sap-reg) :to (:eval 0))
          (offset :scs (signed-reg) :to (:eval 0))
          (value :scs (double-reg)))
-  (:arg-types system-area-pointer signed-num double-float)
+  (:info disp)
+  (:arg-types system-area-pointer signed-num
+              (:constant (constant-displacement 0 ; lowtag
+                                                8 ; double-float size
+                                                0))
+              double-float)
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 5
     (cond ((zerop (tn-offset value))
            ;; Value is in ST0.
-           (inst fstd (make-ea :dword :base sap :index offset))
+           (inst fstd (make-ea :dword :base sap :index offset
+                               :disp (* 8 disp)))
            (unless (zerop (tn-offset result))
-                   ;; Value is in ST0 but not result.
-                   (inst fstd result)))
+             ;; Value is in ST0 but not result.
+             (inst fstd result)))
           (t
            ;; Value is not in ST0.
            (inst fxch value)
-           (inst fstd (make-ea :dword :base sap :index offset))
+           (inst fstd (make-ea :dword :base sap :index offset
+                               :disp (* 8 disp)))
            (cond ((zerop (tn-offset result))
                   ;; The result is in ST0.
                   (inst fstd value))
                  (t
                   ;; Neither value or result are in ST0.
                   (unless (location= value result)
-                          (inst fstd result))
+                    (inst fstd result))
                   (inst fxch value)))))))
 
-(define-vop (%set-sap-ref-double-c)
-  (:translate %set-sap-ref-double)
+(define-vop (%set-sap-ref-double-with-offset-c)
+  (:translate sb!c::%set-sap-ref-double-with-offset)
   (:policy :fast-safe)
   (:args (sap :scs (sap-reg) :to (:eval 0))
          (value :scs (double-reg)))
-  (:arg-types system-area-pointer (:constant (signed-byte 32)) double-float)
-  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 32))
+              (:constant (constant-displacement 0 ; lowtag
+                                                8 ; double-float size
+                                                0))
+              double-float)
+  (:info offset disp)
   (:results (result :scs (double-reg)))
   (:result-types double-float)
   (:generator 4
+    (aver (zerop disp))
     (cond ((zerop (tn-offset value))
            ;; Value is in ST0.
            (inst fstd (make-ea :dword :base sap :disp offset))
            (unless (zerop (tn-offset result))
-                   ;; Value is in ST0 but not result.
-                   (inst fstd result)))
+             ;; Value is in ST0 but not result.
+             (inst fstd result)))
           (t
            ;; Value is not in ST0.
            (inst fxch value)
@@ -302,80 +328,91 @@
                  (t
                   ;; Neither value or result are in ST0.
                   (unless (location= value result)
-                          (inst fstd result))
+                    (inst fstd result))
                   (inst fxch value)))))))
 
 ;;;; SAP-REF-SINGLE
 
-(define-vop (sap-ref-single)
-  (:translate sap-ref-single)
+(define-vop (sap-ref-single-with-offset)
+  (:translate sb!c::sap-ref-single-with-offset)
   (:policy :fast-safe)
   (:args (sap :scs (sap-reg))
-         (offset :scs (signed-reg)))
-  (:arg-types system-area-pointer signed-num)
+         (offset :scs (signed-reg immediate)))
+  (:info disp)
+  (:arg-types system-area-pointer signed-num
+              (:constant (constant-displacement 0 ; lowtag
+                                                4 ; single-float size
+                                                0)))
   (:results (result :scs (single-reg)))
   (:result-types single-float)
   (:generator 5
-     (with-empty-tn@fp-top(result)
-        (inst fld (make-ea :dword :base sap :index offset)))))
-
-(define-vop (sap-ref-single-c)
-  (:translate sap-ref-single)
-  (:policy :fast-safe)
-  (:args (sap :scs (sap-reg)))
-  (:arg-types system-area-pointer (:constant (signed-byte 32)))
-  (:info offset)
-  (:results (result :scs (single-reg)))
-  (:result-types single-float)
-  (:generator 4
-     (with-empty-tn@fp-top(result)
-        (inst fld (make-ea :dword :base sap :disp offset)))))
+     (sc-case offset
+       (immediate
+        (aver (zerop disp))
+        (with-empty-tn@fp-top(result)
+          (inst fld (make-ea :dword :base sap :disp (tn-value offset)))))
+       (t
+        (with-empty-tn@fp-top(result)
+          (inst fld (make-ea :dword :base sap :index offset
+                             :disp (* 4 disp))))))))
 
-(define-vop (%set-sap-ref-single)
-  (:translate %set-sap-ref-single)
+(define-vop (%set-sap-ref-single-with-offset)
+  (:translate sb!c::%set-sap-ref-single-with-offset)
   (:policy :fast-safe)
   (:args (sap :scs (sap-reg) :to (:eval 0))
          (offset :scs (signed-reg) :to (:eval 0))
          (value :scs (single-reg)))
-  (:arg-types system-area-pointer signed-num single-float)
+  (:info disp)
+  (:arg-types system-area-pointer signed-num
+              (:constant (constant-displacement 0 ; lowtag
+                                                4 ; single-float size
+                                                0))
+              single-float)
   (:results (result :scs (single-reg)))
   (:result-types single-float)
   (:generator 5
     (cond ((zerop (tn-offset value))
            ;; Value is in ST0
-           (inst fst (make-ea :dword :base sap :index offset))
+           (inst fst (make-ea :dword :base sap :index offset
+                              :disp (* 4 disp)))
            (unless (zerop (tn-offset result))
-                   ;; Value is in ST0 but not result.
-                   (inst fst result)))
+             ;; Value is in ST0 but not result.
+             (inst fst result)))
           (t
            ;; Value is not in ST0.
            (inst fxch value)
-           (inst fst (make-ea :dword :base sap :index offset))
+           (inst fst (make-ea :dword :base sap :index offset
+                              :disp (* 4 disp)))
            (cond ((zerop (tn-offset result))
                   ;; The result is in ST0.
                   (inst fst value))
                  (t
                   ;; Neither value or result are in ST0
                   (unless (location= value result)
-                          (inst fst result))
+                    (inst fst result))
                   (inst fxch value)))))))
 
-(define-vop (%set-sap-ref-single-c)
-  (:translate %set-sap-ref-single)
+(define-vop (%set-sap-ref-single-with-offset-c)
+  (:translate sb!c::%set-sap-ref-single-with-offset)
   (:policy :fast-safe)
   (:args (sap :scs (sap-reg) :to (:eval 0))
          (value :scs (single-reg)))
-  (:arg-types system-area-pointer (:constant (signed-byte 32)) single-float)
-  (:info offset)
+  (:arg-types system-area-pointer (:constant (signed-byte 32))
+              (:constant (constant-displacement 0 ; lowtag
+                                                4 ; single-float size
+                                                0))
+              single-float)
+  (:info offset disp)
   (:results (result :scs (single-reg)))
   (:result-types single-float)
   (:generator 4
+    (aver (zerop disp))
     (cond ((zerop (tn-offset value))
            ;; Value is in ST0
            (inst fst (make-ea :dword :base sap :disp offset))
            (unless (zerop (tn-offset result))
-                   ;; Value is in ST0 but not result.
-                   (inst fst result)))
+             ;; Value is in ST0 but not result.
+             (inst fst result)))
           (t
            ;; Value is not in ST0.
            (inst fxch value)
@@ -386,7 +423,7 @@
                  (t
                   ;; Neither value or result are in ST0
                   (unless (location= value result)
-                          (inst fst result))
+                    (inst fst result))
                   (inst fxch value)))))))
 
 ;;;; SAP-REF-LONG