Changeset 11820

Timestamp:

05/03/09 10:10:21 (14 years ago)

Author:

ehuelsmann

Message:

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

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass1.lisp (modified) (1 diff)
• compiler-pass2.lisp (modified) (3 diffs)
• jvm.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -361 +361 @@
       (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)))))

trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

@@ -4450 +4450 @@
          (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)
@@ -4457 +4461 @@
           (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))
@@ -4523 +4542 @@
   (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+)

trunk/abcl/src/org/armedbear/lisp/jvm.lisp

@@ -362 +362 @@
   ;; 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
@@ -410 +413 @@
       (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