1.0.10.5: dynamic-extent CONS

[sbcl.git] / src / compiler / x86 / alloc.lisp

diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index f3cdb3c..59d47f5 100644 (file)
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -11,7 +11,9 @@
 
 (in-package "SB!VM")
 \f
-;;;; LIST and LIST*
+;;;; CONS, LIST and LIST*
+(defoptimizer (cons stack-allocate-result) ((&rest args))
+  t)
 (defoptimizer (list stack-allocate-result) ((&rest args))
   (not (null args)))
 (defoptimizer (list* stack-allocate-result) ((&rest args))
@@ -75,27 +77,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 +148,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)
@@ -218,7 +250,6 @@
              (make-ea :byte :base result :disp fun-pointer-lowtag))
        (storew (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
                result 0 fun-pointer-lowtag))
-    (storew result result closure-self-slot fun-pointer-lowtag)
     (loadw temp function closure-fun-slot fun-pointer-lowtag)
     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 
@@ -226,10 +257,11 @@
 (define-vop (make-value-cell)
   (:args (value :scs (descriptor-reg any-reg) :to :result))
   (:results (result :scs (descriptor-reg) :from :eval))
+  (:info stack-allocate-p)
   (:node-var node)
   (:generator 10
     (with-fixed-allocation
-        (result value-cell-header-widetag value-cell-size node)
+        (result value-cell-header-widetag value-cell-size node stack-allocate-p)
       (storew value result value-cell-value-slot other-pointer-lowtag))))
 \f
 ;;;; automatic allocators for primitive objects
@@ -240,9 +272,15 @@
   (: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)
+  (:info name words type lowtag stack-allocate-p)
   (:ignore name)
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
@@ -254,8 +292,10 @@
     ;; 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)))
+    (if (and (not stack-allocate-p)
+             (= lowtag list-pointer-lowtag) (policy node (< speed 3)))
         (let ((dst
+               ;; FIXME: out-of-line dx-allocation
                #.(loop for offset in *dword-regs*
                     collect `(,offset
                               ',(intern (format nil "ALLOCATE-CONS-TO-~A"
@@ -266,7 +306,7 @@
           (aver (null type))
           (inst call (make-fixup dst :assembly-routine)))
         (pseudo-atomic
-         (allocation result (pad-data-block words) node)
+         (allocation result (pad-data-block words) node stack-allocate-p)
          (inst lea result (make-ea :byte :base result :disp lowtag))
          (when type
            (storew (logior (ash (1- words) n-widetag-bits) type)