X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Falloc.lisp;h=bcf3483a7b3072f3b3b89dc3dc964b469ca8062c;hb=b63c4fb9b98fa8188e17ba926e150ba417a74635;hp=47adf8f78c46cdf2c647da42c284ac8ead75e730;hpb=361040122aed4fd4e24bd014818955e5e3028a8f;p=sbcl.git

diff --git a/src/compiler/x86/alloc.lisp b/src/compiler/x86/alloc.lisp
index 47adf8f..bcf3483 100644
--- a/src/compiler/x86/alloc.lisp
+++ b/src/compiler/x86/alloc.lisp
@@ -12,6 +12,10 @@
 (in-package "SB!VM")
 
 ;;;; LIST and LIST*
+(defoptimizer (list stack-allocate-result) ((&rest args))
+  (not (null args)))
+(defoptimizer (list* stack-allocate-result) ((&rest args))
+  (not (null (rest args))))
 
 (define-vop (list-or-list*)
   (:args (things :more t))
@@ -40,7 +44,8 @@
 		     (storew reg ,list ,slot list-pointer-lowtag))))
 	     (let ((cons-cells (if star (1- num) num)))
 	       (pseudo-atomic
-		(allocation res (* (pad-data-block cons-size) cons-cells) node)
+		(allocation res (* (pad-data-block cons-size) cons-cells) node
+                            (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
 		(inst lea res
 		      (make-ea :byte :base res :disp list-pointer-lowtag))
 		(move ptr res)
@@ -110,18 +115,19 @@
 
 (define-vop (make-closure)
   (:args (function :to :save :scs (descriptor-reg)))
-  (:info length)
+  (:info length stack-allocate-p)
   (:temporary (:sc any-reg) temp)
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 10
-   (pseudo-atomic
-    (let ((size (+ length closure-info-offset)))
-      (allocation result (pad-data-block size) node)
-      (inst lea result
-	    (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))
+   (maybe-pseudo-atomic stack-allocate-p
+     (let ((size (+ length closure-info-offset)))
+       (allocation result (pad-data-block size) node
+                   stack-allocate-p)
+       (inst lea result
+             (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))
     (loadw temp function closure-fun-slot fun-pointer-lowtag)
     (storew temp result closure-fun-slot fun-pointer-lowtag))))
 
@@ -181,39 +187,4 @@
      (inst lea result (make-ea :byte :base result :disp lowtag))
      (storew header result 0 lowtag))))
 
-(define-vop (make-symbol)
-  (:policy :fast-safe)
-  (:translate make-symbol)
-  (:args (name :scs (descriptor-reg) :to :eval))
-  (:temporary (:sc unsigned-reg :from :eval) temp)
-  (:results (result :scs (descriptor-reg) :from :argument))
-  (:node-var node)
-  (:generator 37
-    (with-fixed-allocation (result symbol-header-widetag symbol-size node)
-      (storew name result symbol-name-slot other-pointer-lowtag)
-      (storew unbound-marker-widetag
-	      result
-	      symbol-value-slot
-	      other-pointer-lowtag)
-      ;; Set up a random hash value for the symbol. Perhaps the object
-      ;; address could be used for even faster and smaller code!
-      ;; FIXME: We don't mind the symbol hash not being repeatable, so
-      ;; we might as well add in the object address here, too. (Adding entropy
-      ;; is good, even if ANSI doesn't understand that.)
-      (inst imul temp
-	    (make-fixup (extern-alien-name "fast_random_state") :foreign)
-	    1103515245)
-      (inst add temp 12345)
-      (inst mov (make-fixup (extern-alien-name "fast_random_state") :foreign)
-	    temp)
-      ;; We want a positive fixnum for the hash value, so discard the LS bits.
-      ;;
-      ;; FIXME: OK, who wants to tell me (CSR) why these two
-      ;; instructions aren't replaced by (INST AND TEMP #x8FFFFFFC)?
-      ;; Are the following two instructions actually faster?  Does the
-      ;; difference in behaviour really matter?
-      (inst shr temp 1)
-      (inst and temp #xfffffffc)
-      (storew temp result symbol-hash-slot other-pointer-lowtag)
-      (storew nil-value result symbol-plist-slot other-pointer-lowtag)
-      (storew nil-value result symbol-package-slot other-pointer-lowtag))))
+