[armedbear-cvs] r11820 - trunk/abcl/src/org/armedbear/lisp

[Erik Huelsmann]

Author: ehuelsmann
Date: Sun May  3 06:10:21 2009
New Revision: 11820

Log:
Make local GO restore the environment of the TAGBODY,
in case it jumps out of blocks setting the environment.

Modified:
   trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
   trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
   trunk/abcl/src/org/armedbear/lisp/jvm.lisp

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp	Sun May  3 06:10:21 2009
@@ -360,8 +360,13 @@
     (let ((tag-block (tag-block tag)))
       (cond ((eq (tag-compiland tag) *current-compiland*)
              ;; Does the GO leave an enclosing UNWIND-PROTECT?
-             (when (enclosed-by-protected-block-p tag-block)
-               (setf (block-non-local-go-p tag-block) t)))
+             (if (enclosed-by-protected-block-p tag-block)
+                 (setf (block-non-local-go-p tag-block) t)
+                 ;; non-local GO's ensure environment restoration
+                 ;; find out about this local GO
+                 (when (null (block-needs-environment-restoration tag-block))
+                   (setf (block-needs-environment-restoration tag-block)
+                         (enclosed-by-environment-setting-block-p tag-block)))))
             (t
              (setf (block-non-local-go-p tag-block) t)))))
   form)

Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp	Sun May  3 06:10:21 2009
@@ -4449,13 +4449,32 @@
          (BEGIN-BLOCK (gensym))
          (END-BLOCK (gensym))
          (EXIT (gensym))
-         (must-clear-values nil))
+         (must-clear-values nil)
+         environment-register)
+    (when (block-needs-environment-restoration block)
+      (setf environment-register (allocate-register)
+            (block-environment-register block) environment-register))
     ;; Scan for tags.
     (dolist (subform body)
       (when (or (symbolp subform) (integerp subform))
         (let* ((tag (make-tag :name subform :label (gensym) :block block)))
           (push tag local-tags)
           (push tag *visible-tags*))))
+
+    (when environment-register
+      ;; Note: we store the environment register,
+      ;; but since we don't manipulate the environment,
+      ;; we don't need to restore.
+      ;;
+      ;; It's here so local transfers of control can restore
+      ;; what we started with.
+      ;;
+      ;; Non-local transfers of control restore the environment
+      ;; themselves (in the finally of LET/LET*, etc.
+      (emit-push-current-thread)
+      (emit 'getfield +lisp-thread-class+ "lastSpecialBinding"
+            +lisp-special-binding+)
+      (astore environment-register))
     (label BEGIN-BLOCK)
     (do* ((rest body (cdr rest))
           (subform (car rest) (car rest)))
@@ -4522,27 +4541,23 @@
   ;; FIXME What if we're called with a non-NIL representation?
   (declare (ignore representation))
   (let* ((name (cadr form))
-         (tag (find-tag name)))
+         (tag (find-tag name))
+         (tag-block (when tag (tag-block tag))))
     (unless tag
       (error "p2-go: tag not found: ~S" name))
-    (when (eq (tag-compiland tag) *current-compiland*)
-      ;; Local case.
-      (let* ((tag-block (tag-block tag))
-             (register nil))
-        (unless (enclosed-by-protected-block-p tag-block)
-          (dolist (block *blocks*)
-            (if (eq block tag-block)
-                (return)
-                (setf register (or (block-environment-register block) register))))
-          (when register
-            ;; Restore dynamic environment.
-            (aload *thread*)
-            (aload register)
-            (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"
-                  +lisp-special-binding+))
-          (maybe-generate-interrupt-check)
-          (emit 'goto (tag-label tag))
-          (return-from p2-go))))
+    (when (and (eq (tag-compiland tag) *current-compiland*)
+               (not (enclosed-by-protected-block-p tag-block)))
+      ;; Local case with local transfer of control
+      ;;   Note: Local case with non-local transfer of control handled below
+      (when (block-environment-register tag-block)
+        ;; If there's a dynamic environment to restore, do it.
+        (aload *thread*)
+        (aload (block-environment-register tag-block))
+        (emit 'putfield +lisp-thread-class+ "lastSpecialBinding"
+              +lisp-special-binding+))
+      (maybe-generate-interrupt-check)
+      (emit 'goto (tag-label tag))
+      (return-from p2-go))
     ;; Non-local GO.
     (emit 'new +lisp-go-class+)
     (emit 'dup)

Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp	(original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp	Sun May  3 06:10:21 2009
@@ -361,6 +361,9 @@
   non-local-return-p
   ;; True if a tag in this tagbody is the target of a non-local GO.
   non-local-go-p
+  ;; If non-nil, the TAGBODY contains local blocks which "contaminate" the
+  ;; environment, with GO forms in them which target tags in this TAGBODY
+  needs-environment-restoration
   ;; If non-nil, register containing saved dynamic environment for this block.
   environment-register
   ;; Only used in LET/LET*/M-V-B nodes.
@@ -409,6 +412,14 @@
     (when (block-requires-non-local-exit-p enclosing-block)
       (return-from enclosed-by-protected-block-p t))))
 
+(defknown enclosed-by-environment-setting-block-p (&optional outermost-block)
+  boolean)
+(defun enclosed-by-environment-setting-block-p (&optional outermost-block)
+  (dolist (enclosing-block *blocks*)
+    (when (eq enclosing-block outermost-block)
+      (return nil))
+    (when (block-environment-register enclosing-block)
+      (return t))))
 
 (defstruct tag
   name