Changeset 11851

Timestamp:

05/09/09 20:05:25 (14 years ago)

Author:

ehuelsmann

Message:

Local transfer of control with environment restoration
efficiency: don't save the environment on each block/tagbody start.

Only restore the environment when restoration is required,
using the value in the outermost block which saved an environment.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

• compiler-pass2.lisp (modified) (5 diffs)
• jvm.lisp (modified) (1 diff)

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

@@ -4412 +4412 @@
          (END-BLOCK (gensym))
          (EXIT (gensym))
-         (must-clear-values nil)
-         environment-register)
-    (when (block-needs-environment-restoration block)
-      (setf environment-register (allocate-register)
-            (block-environment-register block) environment-register))
+         (must-clear-values nil))
     ;; Scan for tags.
     (dolist (tag (block-tags block))
       (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.
-      (save-dynamic-environment environment-register))
     (label BEGIN-BLOCK)
     (do* ((rest body (cdr rest))
@@ -4510 +4495 @@
       ;; Local case with local transfer of control
       ;;   Note: Local case with non-local transfer of control handled below
-      (when (block-environment-register tag-block)
+      (when (and (block-needs-environment-restoration tag-block)
+                 (enclosed-by-environment-setting-block-p tag-block))
         ;; If there's a dynamic environment to restore, do it.
-  (restore-dynamic-environment (block-environment-register tag-block)))
+  (restore-dynamic-environment (environment-register-to-restore tag-block)))
       (maybe-generate-interrupt-check)
       (emit 'goto (tag-label tag))
@@ -4620 +4606 @@
           (dformat t "*all-variables* = ~S~%"
                    (mapcar #'variable-name *all-variables*))
-          (when (block-needs-environment-restoration block)
-            ;; Save the current dynamic environment.
-            (setf (block-environment-register block) (allocate-register))
-            (save-dynamic-environment (block-environment-register block)))
           (setf (block-catch-tag block) (gensym))
           (let* ((*register* *register*)
@@ -4658 +4640 @@
                       *handlers*)))
             (label BLOCK-EXIT))
-          (when (block-environment-register block)
-            ;; We saved the dynamic environment above. Restore it now.
-            (restore-dynamic-environment (block-environment-register block)))
           (fix-boxing representation nil)))))
 
@@ -4682 +4661 @@
             (emit-clear-values))
           (compile-form result-form (block-target block) nil)
+          (when (and (block-needs-environment-restoration block)
+                     (enclosed-by-environment-setting-block-p block))
+            (restore-dynamic-environment (environment-register-to-restore block)))
           (emit 'goto (block-exit block))
           (return-from p2-return-from))))

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

@@ -428 +428 @@
       (return t))))
 
+(defknown environment-register-to-restore (&optional t) t)
+(defun environment-register-to-restore (&optional outermost-block)
+  "Returns the environment register which contains the
+saved environment from the outermost enclosing block:
+
+That's the one which contains the environment used in the outermost block."
+  (flet ((outermost-register (last-register block)
+           (when (eq block outermost-block)
+             (return-from environment-register-to-restore last-register))
+           (or (block-environment-register block)
+               last-register)))
+    (reduce #'outermost-register *blocks*
+            :initial-value nil)))
+
 (defstruct tag
   ;; The symbol (or integer) naming the tag