From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Mon, 20 Jun 2005 12:43:50 +0000 (+0000)
Subject: 0.9.1.61: really allocate dx closures on stack on ppc and alpha
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=453291c1102e2bc19f1d6a25a63fe99460206b26;p=sbcl.git

0.9.1.61: really allocate dx closures on stack on ppc and alpha
  * add a test-case.
  * untested on alpha.
---

diff --git a/src/compiler/alpha/alloc.lisp b/src/compiler/alpha/alloc.lisp
index 9a440a3..99c95e2 100644
--- a/src/compiler/alpha/alloc.lisp
+++ b/src/compiler/alpha/alloc.lisp
@@ -45,7 +45,7 @@
 			     (load-stack-tn temp ,tn)
 			     temp))))
 		     (storew reg ,list ,slot list-pointer-lowtag))))
-	     (let* ((dx-p (awhen (sb!c::node-lvar node) (sb!c::lvar-dynamic-extent it)))
+	     (let* ((dx-p (node-stack-allocate-p node))
                     (cons-cells (if star (1- num) num))
                     (space (* (pad-data-block cons-size) cons-cells)))
 	       (pseudo-atomic (:extra (if dx-p 0 space))
@@ -125,19 +125,17 @@
 (define-vop (make-closure)
   (:args (function :to :save :scs (descriptor-reg)))
   (:info length stack-allocate-p)
-  (:ignore stack-allocate-p)
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:results (result :scs (descriptor-reg)))
   (:node-var node)
   (:generator 10
     (let* ((size (+ length closure-info-offset))
-           (alloc-size (pad-data-block size))
-           (dx-p (node-stack-allocate-p node)))
+           (alloc-size (pad-data-block size)))
       (inst li
 	    (logior (ash (1- size) n-widetag-bits) closure-header-widetag)
 	    temp)
-      (pseudo-atomic (:extra (if dx-p 0 alloc-size))
-        (cond (dx-p
+      (pseudo-atomic (:extra (if stack-allocate-p 0 alloc-size))
+        (cond (stack-allocate-p
                ;; no need to align CSP: FUN-POINTER-LOWTAG already has
                ;; the corresponding bit set
                (inst bis csp-tn fun-pointer-lowtag result)
diff --git a/src/compiler/ppc/alloc.lisp b/src/compiler/ppc/alloc.lisp
index d1551dc..0799e51 100644
--- a/src/compiler/ppc/alloc.lisp
+++ b/src/compiler/ppc/alloc.lisp
@@ -126,22 +126,19 @@
 (define-vop (make-closure)
   (:args (function :to :save :scs (descriptor-reg)))
   (:info length stack-allocate-p)
-  (:ignore stack-allocate-p)
   (:temporary (:scs (non-descriptor-reg)) temp)
   (:temporary (:sc non-descriptor-reg :offset nl3-offset) pa-flag)
   (:results (result :scs (descriptor-reg)))
-  (:node-var node)
   (:generator 10
     (let* ((size (+ length closure-info-offset))
 	   (alloc-size (pad-data-block size))
-	   (dx-p (node-stack-allocate-p node))
-	   (allocation-area-tn (if dx-p csp-tn alloc-tn)))
-      (pseudo-atomic (pa-flag :extra (if dx-p 0 alloc-size))
+	   (allocation-area-tn (if stack-allocate-p csp-tn alloc-tn)))
+      (pseudo-atomic (pa-flag :extra (if stack-allocate-p 0 alloc-size))
 	;; no need to align CSP for DX: FUN-POINTER-LOWTAG already has
 	;; the corresponding bit set
 	(inst clrrwi. result allocation-area-tn n-lowtag-bits)
-	(when dx-p
-	  (inst addi csp-tn alloc-size))
+	(when stack-allocate-p
+	  (inst addi csp-tn csp-tn alloc-size))
 	(inst ori result result fun-pointer-lowtag)
 	(inst lr temp (logior (ash (1- size) n-widetag-bits) closure-header-widetag))
 	(storew temp result 0 fun-pointer-lowtag)))
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 6844273..9aa52b6 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -108,11 +108,24 @@
     (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
     (assert (equal *x* '(1 2 3 4)))))
 
+;;; closure
 
+(declaim (notinline true))
+(defun true (x)
+  (declare (ignore x))
+  t)
+
+(defun-with-dx dxclosure (x)
+  (flet ((f (y) 
+	   (+ y x)))
+    (declare (dynamic-extent #'f))
+    (true #'f)))
+
+(assert (eq t (dxclosure 13)))
 
 
 (defmacro assert-no-consing (form &optional times)
-  `(%assert-no-consing (lambda () ,form ,times)))
+  `(%assert-no-consing (lambda () ,form) ,times))
 (defun %assert-no-consing (thunk &optional times)
   (let ((before (get-bytes-consed))
         (times (or times 10000)))
@@ -123,6 +136,7 @@
 
 #+(or x86 x86-64 alpha ppc)
 (progn
+  (assert-no-consing (dxclosure 42))
   (assert-no-consing (dxlength 1 2 3))
   (assert-no-consing (dxlength t t t t t t))
   (assert-no-consing (dxlength))
diff --git a/version.lisp-expr b/version.lisp-expr
index 50e8c8e..984b4e7 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".)
-"0.9.1.60"
+"0.9.1.61"