[Sbcl-commits] CVS: sbcl/src/compiler/x86 alloc.lisp, 1.24, 1.25 macros.lisp, 1.39, 1.40

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

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

Modified Files:
	alloc.lisp macros.lisp 
Log Message:
1.0.2.4: Improve inlined array heap allocation on x86.
	...allow IMMEDIATE SCs to ALLOCATE-VECTOR-ON-HEAP;
	...use shorter instructions to set the widetag.

	Cuts a couple of pages off of sbcl.core.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/alloc.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- alloc.lisp	6 Oct 2006 10:54:16 -0000	1.24
+++ alloc.lisp	29 Jan 2007 18:30:25 -0000	1.25
@@ -75,27 +75,52 @@
 
 ;;; ALLOCATE-VECTOR
 (define-vop (allocate-vector-on-heap)
-  (:args (type :scs (unsigned-reg))
-         (length :scs (any-reg))
-         (words :scs (any-reg)))
+  (:args (type :scs (unsigned-reg immediate))
+         (length :scs (any-reg immediate))
+         (words :scs (any-reg immediate)))
   (:results (result :scs (descriptor-reg) :from :load))
   (:arg-types positive-fixnum
               positive-fixnum
               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 and result (lognot lowtag-mask))
-    (pseudo-atomic
-      (allocation result result)
-      (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
-      (storew type result 0 other-pointer-lowtag)
-      (storew length result vector-length-slot other-pointer-lowtag))))
+    (let ((size (sc-case words
+                  (immediate
+                   (logandc2 (+ (fixnumize (tn-value words))
+                                (+ (1- (ash 1 n-lowtag-bits))
+                                   (* vector-data-offset n-word-bytes)))
+                             lowtag-mask))
+                  (t
+                   (inst lea result (make-ea :byte :base words :disp
+                                             (+ (1- (ash 1 n-lowtag-bits))
+                                                (* vector-data-offset
+                                                   n-word-bytes))))
+                   (inst and result (lognot lowtag-mask))
+                   result))))
+      (pseudo-atomic
+       (allocation result size)
+       (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
+       (sc-case type
+         (immediate
+          (aver (typep (tn-value type) '(unsigned-byte 8)))
+          (storeb (tn-value type) result 0 other-pointer-lowtag))
+         (t
+          (storew type result 0 other-pointer-lowtag)))
+       (sc-case length
+         (immediate
+          (let ((fixnum-length (fixnumize (tn-value length))))
+            (typecase fixnum-length
+              ((unsigned-byte 8)
+               (storeb fixnum-length result
+                       vector-length-slot other-pointer-lowtag))
+              (t
+               (storew fixnum-length result
+                       vector-length-slot other-pointer-lowtag)))))
+         (t
+          (storew length result vector-length-slot other-pointer-lowtag)))))))
 
 (define-vop (allocate-vector-on-stack)
-  (:args (type :scs (unsigned-reg))
+  (:args (type :scs (unsigned-reg immediate))
          (length :scs (any-reg))
          (words :scs (any-reg) :target ecx))
   (:temporary (:sc any-reg :offset ecx-offset :from (:argument 2)) ecx)
@@ -121,7 +146,12 @@
     (inst lea res
           (make-ea :byte :base result :disp (* vector-data-offset n-word-bytes)))
     (inst lea result (make-ea :byte :base result :disp other-pointer-lowtag))
-    (storew type result 0 other-pointer-lowtag)
+    (sc-case type
+      (immediate
+       (aver (typep (tn-value type) '(unsigned-byte 8)))
+       (storeb (tn-value type) result 0 other-pointer-lowtag))
+      (t
+       (storew type result 0 other-pointer-lowtag)))
     (storew length result vector-length-slot other-pointer-lowtag)
     (inst xor zero zero)
     (inst rep)

Index: macros.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/macros.lisp,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -d -r1.39 -r1.40
--- macros.lisp	27 Jan 2007 03:57:20 -0000	1.39
+++ macros.lisp	29 Jan 2007 18:30:25 -0000	1.40
@@ -46,8 +46,8 @@
     `(unless (location= ,n-dst ,n-src)
        (inst mov ,n-dst ,n-src))))
 
-(defmacro make-ea-for-object-slot (ptr slot lowtag)
-  `(make-ea :dword :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
+(defmacro make-ea-for-object-slot (ptr slot lowtag &optional (size :dword))
+  `(make-ea ,size :base ,ptr :disp (- (* ,slot n-word-bytes) ,lowtag)))
 
 (defmacro loadw (value ptr &optional (slot 0) (lowtag 0))
   `(inst mov ,value (make-ea-for-object-slot ,ptr ,slot ,lowtag)))
@@ -56,6 +56,11 @@
   (once-only ((value value))
     `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag) ,value)))
 
+;;; A handy macro for storing widetags.
+(defmacro storeb (value ptr &optional (slot 0) (lowtag 0))
+  (once-only ((value value))
+    `(inst mov (make-ea-for-object-slot ,ptr ,slot ,lowtag :byte) ,value)))
+
 (defmacro pushw (ptr &optional (slot 0) (lowtag 0))
   `(inst push (make-ea-for-object-slot ,ptr ,slot ,lowtag)))