X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Falloc.lisp;h=e7fc391db36200bd0c32f8c03efcd27674a5dd3f;hb=43b1750ede8767928788b158399d3c5d2910855a;hp=d11155785e14b06f68a44854f8cd82ce4d68d33d;hpb=0d871fd7a98fc4af92a8b942a1154761466ad8c9;p=sbcl.git

diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index d111557..e7fc391 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)
@@ -109,25 +134,36 @@
   (: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 and result (lognot lowtag-mask))
-    ;; FIXME: It would be good to check for stack overflow here.
-    (move ecx words)
-    (inst shr ecx n-fixnum-tag-bits)
-    (allocation result result node t)
-    (inst cld)
-    (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)
-    (storew length result vector-length-slot other-pointer-lowtag)
-    (inst xor zero zero)
-    (inst rep)
-    (inst stos zero)))
+    (let ((unboxed-elements-p (and (sc-is type immediate)
+                                   (/= (tn-value type)
+                                       simple-vector-widetag))))
+      (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))
+      ;; FIXME: It would be good to check for stack overflow here.
+      (move ecx words)
+      (inst shr ecx n-fixnum-tag-bits)
+      (allocation result result node t)
+      (unless unboxed-elements-p
+        (inst cld))
+      (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))
+      (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)
+      (unless unboxed-elements-p
+        (inst xor zero zero)
+        (inst rep)
+        (inst stos zero)))))
+
+(in-package "SB!C")
 
-(in-package :sb!c)
 (defoptimizer (allocate-vector stack-allocate-result)
     ((type length words) node)
   (ecase (policy node stack-allocate-vector)
@@ -158,7 +194,8 @@
 
     (dolist (arg args)
       (annotate-1-value-lvar arg))))
-(in-package :sb!vm)
+
+(in-package "SB!VM")
 
 ;;;
 (define-vop (allocate-code-object)
@@ -237,6 +274,12 @@
   (:generator 1
     (inst mov result unbound-marker-widetag)))
 
+(define-vop (make-funcallable-instance-tramp)
+  (:args)
+  (:results (result :scs (any-reg)))
+  (:generator 1
+    (inst lea result (make-fixup "funcallable_instance_tramp" :foreign))))
+
 (define-vop (fixed-alloc)
   (:args)
   (:info name words type lowtag)
@@ -244,14 +287,32 @@
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 50
-    (pseudo-atomic
-     (allocation result (pad-data-block words) node)
-     (inst lea result (make-ea :byte :base result :disp lowtag))
-     (when type
-       (storew (logior (ash (1- words) n-widetag-bits) type)
-               result
-               0
-               lowtag)))))
+    ;; We special case the allocation of conses, because they're
+    ;; extremely common and because the pseudo-atomic sequence on x86
+    ;; is relatively heavyweight.  However, if the user asks for top
+    ;; speed, we accomodate him.  The primary reason that we don't
+    ;; also check for (< SPEED SPACE) is because we want the space
+    ;; savings that these out-of-line allocation routines bring whilst
+    ;; compiling SBCL itself.  --njf, 2006-07-08
+    (if (and (= lowtag list-pointer-lowtag) (policy node (< speed 3)))
+        (let ((dst
+               #.(loop for offset in *dword-regs*
+                    collect `(,offset
+                              ',(intern (format nil "ALLOCATE-CONS-TO-~A"
+                                                (svref *dword-register-names*
+                                                       offset)))) into cases
+                    finally (return `(case (tn-offset result)
+                                       ,@cases)))))
+          (aver (null type))
+          (inst call (make-fixup dst :assembly-routine)))
+        (pseudo-atomic
+         (allocation result (pad-data-block words) node)
+         (inst lea result (make-ea :byte :base result :disp lowtag))
+         (when type
+           (storew (logior (ash (1- words) n-widetag-bits) type)
+                   result
+                   0
+                   lowtag))))))
 
 (define-vop (var-alloc)
   (:args (extra :scs (any-reg)))
@@ -274,5 +335,3 @@
      (allocation result bytes node)
      (inst lea result (make-ea :byte :base result :disp lowtag))
      (storew header result 0 lowtag))))
-
-