From: Nathan Froyd <froydnj@cs.rice.edu>
Date: Mon, 29 Jan 2007 18:30:24 +0000 (+0000)
Subject: 1.0.2.4: Improve inlined array heap allocation on x86.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0da101cd78f9b7b772f6a469ade38b01e5de982b;p=sbcl.git

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.
---

diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index 9306c1b..8bc9c86 100644
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -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)
diff --git a/src/compiler/x86/macros.lisp b/src/compiler/x86/macros.lisp
index fdf55a2..5f0a2d8 100644
--- a/src/compiler/x86/macros.lisp
+++ b/src/compiler/x86/macros.lisp
@@ -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)))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 4ed7224..dbba1e1 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.2.3"
+"1.0.2.4"