Changeset 13021

Timestamp:

11/11/10 12:40:40 (11 years ago)

Author:

ehuelsmann

Message:

Reduce the number of ATHROW instructions executed while running
the Maxima test suite by ~60%.

Note: because we don't generate stack dumps on our ControlTransfer?
exception derivatives, we only save 2% execution time.

[Note from the future: this commit requires a FASL version
number update which got committed at r13064.]

File:

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

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

@@ -2998 +2998 @@
       (compile-progn-body (cdddr form) target))
     (when bind-special-p
-      (restore-environment-and-make-handler (m-v-b-environment-register block)
-              label-START))))
+      (restore-dynamic-environment (m-v-b-environment-register block)))))
 
 (defun propagate-vars (block)
@@ -3356 +3355 @@
         (compile-progn-body (cddr form) target representation)))
     (when specialp
-      (restore-environment-and-make-handler (let-environment-register block)
-              label-START))))
+      (restore-dynamic-environment (let-environment-register block)))))
 
 (defknown p2-locally-node (t t t) t)
@@ -3380 +3378 @@
          (RETHROW (gensym))
          (EXIT (gensym))
-         (must-clear-values nil))
+         (must-clear-values nil)
+         (specials-register (when (tagbody-non-local-go-p block)
+                              (allocate-register))))
     ;; Scan for tags.
     (dolist (tag (tagbody-tags block))
@@ -3392 +3392 @@
       (emit-invokespecial-init +lisp-object+ '())
       (emit-new-closure-binding (tagbody-id-variable block)))
+    (when (tagbody-non-local-go-p block)
+      (save-dynamic-environment specials-register))
     (label BEGIN-BLOCK)
     (do* ((rest body (cdr rest))
@@ -3428 +3430 @@
         (emit-getfield +lisp-go+ "tag" +lisp-object+) ; Stack depth is still 1.
         (astore tag-register)
+        (restore-dynamic-environment specials-register)
         ;; Don't actually generate comparisons for tags
         ;; to which there is no non-local GO instruction
@@ -3573 +3576 @@
          (BEGIN-BLOCK (gensym))
          (END-BLOCK (gensym))
-         (BLOCK-EXIT (block-exit block)))
+         (BLOCK-EXIT (block-exit block))
+         (specials-register (when (block-non-local-return-p block)
+                              (allocate-register))))
     (setf (block-target block) target)
     (when (block-id-variable block)
@@ -3584 +3589 @@
     (dformat t "*all-variables* = ~S~%"
              (mapcar #'variable-name *all-variables*))
+    (when (block-non-local-return-p block)
+      (save-dynamic-environment specials-register))
     (label BEGIN-BLOCK) ; Start of protected range, for non-local returns
     ;; Implicit PROGN.
@@ -3611 +3618 @@
         (emit 'athrow)
         (label THIS-BLOCK)
+        (restore-dynamic-environment specials-register)
         (emit-getfield +lisp-return+ "result" +lisp-object+)
         (emit-move-from-stack target) ; Stack depth is 0.
@@ -3732 +3740 @@
     (let ((*blocks* (cons block *blocks*)))
       (compile-progn-body (cdddr form) target representation))
-    (restore-environment-and-make-handler environment-register label-START)))
+    (restore-dynamic-environment environment-register)))
 
 (defun p2-quote (form target representation)
@@ -6449 +6457 @@
            (RETHROW (gensym))
            (DEFAULT-HANDLER (gensym))
-           (EXIT (gensym)))
+           (EXIT (gensym))
+           (specials-register (allocate-register)))
       (compile-form (second form) tag-register nil) ; Tag.
       (emit-push-current-thread)
@@ -6457 +6466 @@
       (let ((*blocks* (cons block *blocks*)))
         ; Stack depth is 0.
+        (save-dynamic-environment specials-register)
         (label BEGIN-PROTECTED-RANGE) ; Start of protected range.
         (compile-progn-body (cddr form) target) ; Implicit PROGN.
@@ -6469 +6479 @@
       ;; catch-all handler, which will do a re-throw.
       (emit 'if_acmpne RETHROW) ; Stack depth is 1.
+      (restore-dynamic-environment specials-register)
       (emit-push-current-thread)
       (emit-invokevirtual +lisp-throw+ "getResult"
@@ -6534 +6545 @@
            (result-register (allocate-register))
            (values-register (allocate-register))
+           (specials-register (allocate-register))
            (BEGIN-PROTECTED-RANGE (gensym))
            (END-PROTECTED-RANGE (gensym))
@@ -6542 +6554 @@
 
       (let* ((*blocks* (cons block *blocks*)))
+        (save-dynamic-environment specials-register)
         (label BEGIN-PROTECTED-RANGE)
         (compile-form protected-form result-register nil)
@@ -6561 +6574 @@
       (emit-getfield +lisp-thread+ "_values" +lisp-object-array+)
       (astore values-register)
+      (restore-dynamic-environment specials-register)
       (let ((*register* *register*))
         (compile-progn-body cleanup-forms nil nil))
@@ -6908 +6922 @@
 
     (when (compiland-environment-register compiland)
-      (restore-environment-and-make-handler
-       (compiland-environment-register compiland) label-START))
+      (restore-dynamic-environment (compiland-environment-register compiland)))
 
     (unless *code*