Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/tests
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv18345/tests

Modified Files:
	dynamic-extent.impure.lisp threads.impure.lisp 
Log Message:
1.0.44.36: test case for bug #681092

>From the bug report.  Also remove needless quotes in some test names.


Index: dynamic-extent.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/dynamic-extent.impure.lisp,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -d -r1.52 -r1.53
--- dynamic-extent.impure.lisp	8 Sep 2010 01:12:16 -0000	1.52
+++ dynamic-extent.impure.lisp	27 Nov 2010 21:08:53 -0000	1.53
@@ -903,3 +903,13 @@
              (assert (eql x (car (aref vec 0)))))))
     (assert-no-consing (test 42))))
 
+(defun bug-681092 ()
+  (declare (optimize speed))
+  (let ((c 0))
+    (flet ((bar () c))
+      (declare (dynamic-extent #'bar))
+      (do () ((list) (bar))
+        (setf c 10)
+        (return (bar))))))
+(with-test (:name :bug-681092)
+  (assert (= 10 (bug-681092))))

Index: threads.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/threads.impure.lisp,v
retrieving revision 1.82
retrieving revision 1.83
diff -u -d -r1.82 -r1.83
--- threads.impure.lisp	19 Sep 2010 14:14:16 -0000	1.82
+++ threads.impure.lisp	27 Nov 2010 21:08:53 -0000	1.83
@@ -154,16 +154,16 @@
   (sleep 3)
   (assert (not (thread-alive-p thread))))
 
-(with-test (:name '(:join-thread :nlx :default))
+(with-test (:name (:join-thread :nlx :default))
   (let ((sym (gensym)))
     (assert (eq sym (join-thread (make-thread (lambda () (sb-ext:quit)))
                                  :default sym)))))
 
-(with-test (:name '(:join-thread :nlx :error))
+(with-test (:name (:join-thread :nlx :error))
   (raises-error? (join-thread (make-thread (lambda () (sb-ext:quit))))
                  join-thread-error))
 
-(with-test (:name '(:join-thread :multiple-values))
+(with-test (:name (:join-thread :multiple-values))
   (assert (equal '(1 2 3)
                  (multiple-value-list
                   (join-thread (make-thread (lambda () (values 1 2 3))))))))
@@ -1331,7 +1331,7 @@
   (format t "ok~%")
   (force-output))
 
-(with-test (:name '(:hash-cache :subtypep))
+(with-test (:name (:hash-cache :subtypep))
   (dotimes (i 10)
     (sb-thread:make-thread #'subtypep-hash-cache-test)))
 (format t "hash-cache tests done~%")

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv18345

Modified Files:
	version.lisp-expr 
Log Message:
1.0.44.36: test case for bug #681092

>From the bug report.  Also remove needless quotes in some test names.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5146
retrieving revision 1.5147
diff -u -d -r1.5146 -r1.5147
--- version.lisp-expr	27 Nov 2010 03:02:03 -0000	1.5146
+++ version.lisp-expr	27 Nov 2010 21:08:53 -0000	1.5147
@@ -20,4 +20,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.44.35"
+"1.0.44.36"

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27442

Modified Files:
	version.lisp-expr 
Log Message:
1.0.44.35: Use DX-FLET instead of FLET in WITHOUT-{INTERRUPTS,GCING}.

  * With the local functions declared to be DYNAMIC-EXTENT, the
new d-x closure analysis can elide the value cells involved
entirely.

  * This fixes lp#674458 (introduced in 1.0.44.16).


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5145
retrieving revision 1.5146
diff -u -d -r1.5145 -r1.5146
--- version.lisp-expr	27 Nov 2010 03:01:50 -0000	1.5145
+++ version.lisp-expr	27 Nov 2010 03:02:03 -0000	1.5146
@@ -20,4 +20,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.44.34"
+"1.0.44.35"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27442/src/code

Modified Files:
	signal.lisp sysmacs.lisp 
Log Message:
1.0.44.35: Use DX-FLET instead of FLET in WITHOUT-{INTERRUPTS,GCING}.

  * With the local functions declared to be DYNAMIC-EXTENT, the
new d-x closure analysis can elide the value cells involved
entirely.

  * This fixes lp#674458 (introduced in 1.0.44.16).


Index: signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/signal.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- signal.lisp	16 Feb 2009 22:16:20 -0000	1.25
+++ signal.lisp	27 Nov 2010 03:02:03 -0000	1.26
@@ -102,7 +102,7 @@
     (lambda () (with-local-interrupts ...)))
 "
   (with-unique-names (outer-allow-with-interrupts without-interrupts-body)
-    `(flet ((,without-interrupts-body ()
+    `(dx-flet ((,without-interrupts-body ()
               (declare (disable-package-locks allow-with-interrupts
                                               with-local-interrupts))
               (macrolet

Index: sysmacs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sysmacs.lisp,v
retrieving revision 1.34
retrieving revision 1.35
diff -u -d -r1.34 -r1.35
--- sysmacs.lisp	6 Aug 2010 18:49:42 -0000	1.34
+++ sysmacs.lisp	27 Nov 2010 03:02:03 -0000	1.35
@@ -51,7 +51,7 @@
 locks, application code can never be certain that this invariant is
 maintained."
   (with-unique-names (without-gcing-body)
-    `(flet ((,without-gcing-body ()
+    `(dx-flet ((,without-gcing-body ()
               ,@body))
        (if *gc-inhibit*
            (,without-gcing-body)

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27373/src/compiler

Modified Files:
	gtn.lisp 
Log Message:
1.0.44.34: gtn: KLUDGE the lambda-var assignment to not break tail-calls.

  * As an utter KLUDGE, when assigning TNs for closed-over lambda
variables with implicit value-cells, make the TNs component-live
instead of physenv-live.  This prevents any possible problems with
the new physenv introduced by a tail-call overwriting the storage
for the variable.


Index: gtn.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/gtn.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- gtn.lisp	9 Nov 2010 19:45:23 -0000	1.19
+++ gtn.lisp	27 Nov 2010 03:01:50 -0000	1.20
@@ -56,6 +56,16 @@
           ;; live over the dynamic contour of the physenv.
           (setf (tn-sc res) (svref *backend-sc-numbers*
                                    sb!vm:control-stack-sc-number))
+          ;; KLUDGE: In the case of a tail-local-call, the entire
+          ;; stack frame is overwritten by the physenv of the called
+          ;; function.  Unfortunately, the tail-call appears to end
+          ;; the dynamic contour of the physenv, meaning that the
+          ;; stack slot occupied by the LAMBDA-VAR may be reassigned.
+          ;; Ideally, we might make the TN physenv-live across the
+          ;; physenvs of the tail-set of the lambda, but as a stopgap
+          ;; we can make it component-live instead.
+          (component-live-tn res)
+          #+(or)
           (physenv-live-tn res (lambda-physenv fun)))
 
          (debug-variable-p

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27373

Modified Files:
	version.lisp-expr 
Log Message:
1.0.44.34: gtn: KLUDGE the lambda-var assignment to not break tail-calls.

  * As an utter KLUDGE, when assigning TNs for closed-over lambda
variables with implicit value-cells, make the TNs component-live
instead of physenv-live.  This prevents any possible problems with
the new physenv introduced by a tail-call overwriting the storage
for the variable.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5144
retrieving revision 1.5145
diff -u -d -r1.5144 -r1.5145
--- version.lisp-expr	27 Nov 2010 03:01:34 -0000	1.5144
+++ version.lisp-expr	27 Nov 2010 03:01:50 -0000	1.5145
@@ -20,4 +20,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.44.33"
+"1.0.44.34"

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27314

Modified Files:
	version.lisp-expr 
Log Message:
1.0.44.33: ir2tran: Correctly set up d-x closure values for tail-local-calls.

  * Tail-local-call re-uses the current frame.  It therefore needs to
use the old-fp value from the current frame in EMIT-PSETQ-MOVES.

  * "implicit" value cells need to use the /current/ frame pointer in
EMIT-PSETQ-MOVES to correctly initialize the closure.

  * Therefore: Add a new &optional argument to EMIT-PSETQ-MOVES for
the frame-pointer to be used in closure initialization.

  * This fixes the obvious part of lp#681092, but unless there is a
guarantee that the stack slots used for the "implicit" value cells
remain unused in the tail-called function then all this does is drive
the bug to become more subtle.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.5143
retrieving revision 1.5144
diff -u -d -r1.5143 -r1.5144
--- version.lisp-expr	19 Nov 2010 10:57:30 -0000	1.5143
+++ version.lisp-expr	27 Nov 2010 03:01:34 -0000	1.5144
@@ -20,4 +20,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.44.32"
+"1.0.44.33"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27314/src/compiler

Modified Files:
	ir2tran.lisp 
Log Message:
1.0.44.33: ir2tran: Correctly set up d-x closure values for tail-local-calls.

  * Tail-local-call re-uses the current frame.  It therefore needs to
use the old-fp value from the current frame in EMIT-PSETQ-MOVES.

  * "implicit" value cells need to use the /current/ frame pointer in
EMIT-PSETQ-MOVES to correctly initialize the closure.

  * Therefore: Add a new &optional argument to EMIT-PSETQ-MOVES for
the frame-pointer to be used in closure initialization.

  * This fixes the obvious part of lp#681092, but unless there is a
guarantee that the stack slots used for the "implicit" value cells
remain unused in the tail-called function then all this does is drive
the bug to become more subtle.


Index: ir2tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir2tran.lisp,v
retrieving revision 1.84
retrieving revision 1.85
diff -u -d -r1.84 -r1.85
--- ir2tran.lisp	9 Nov 2010 19:45:36 -0000	1.84
+++ ir2tran.lisp	27 Nov 2010 03:01:35 -0000	1.85
@@ -783,9 +783,15 @@
 ;;; OLD-FP. If null, then the call is to the same environment (an
 ;;; :ASSIGNMENT), so we only move the arguments, and leave the
 ;;; environment alone.
-(defun emit-psetq-moves (node block fun old-fp)
+;;;
+;;; CLOSURE-FP is for calling a closure that has "implicit" value
+;;; cells (stored in the allocating stack frame), and is the frame
+;;; pointer TN to use for values allocated in the outbound stack
+;;; frame.  This is distinct from OLD-FP for the specific case of a
+;;; tail-local-call.
+(defun emit-psetq-moves (node block fun old-fp &optional (closure-fp old-fp))
   (declare (type combination node) (type ir2-block block) (type clambda fun)
-           (type (or tn null) old-fp))
+           (type (or tn null) old-fp closure-fp))
   (let ((actuals (mapcar (lambda (x)
                            (when x
                              (lvar-tn node block x)))
@@ -815,7 +821,7 @@
         (let ((this-1env (node-physenv node))
               (called-env (physenv-info (lambda-physenv fun))))
           (dolist (thing (ir2-physenv-closure called-env))
-            (temps (closure-initial-value (car thing) this-1env old-fp))
+            (temps (closure-initial-value (car thing) this-1env closure-fp))
             (locs (cdr thing)))
           (temps old-fp)
           (locs (ir2-physenv-old-fp called-env))))
@@ -828,9 +834,16 @@
 ;;; function's passing location.
 (defun ir2-convert-tail-local-call (node block fun)
   (declare (type combination node) (type ir2-block block) (type clambda fun))
-  (let ((this-env (physenv-info (node-physenv node))))
+  (let ((this-env (physenv-info (node-physenv node)))
+        (current-fp (make-stack-pointer-tn)))
     (multiple-value-bind (temps locs)
-        (emit-psetq-moves node block fun (ir2-physenv-old-fp this-env))
+        (emit-psetq-moves node block fun
+                          (ir2-physenv-old-fp this-env) current-fp)
+
+      ;; If we're about to emit a move from CURRENT-FP then we need to
+      ;; initialize it.
+      (when (find current-fp temps)
+        (vop current-fp node block current-fp))
 
       (mapc (lambda (temp loc)
               (emit-move node block temp loc))