Changeset 11820 for trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp

Timestamp:

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

Author:

ehuelsmann

Message:

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

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (modified) (3 diffs)

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+)