Changeset 11819

Timestamp:

05/03/09 08:46:39 (14 years ago)

Author:

ehuelsmann

Message:

Small refactoring: introduce a centralized definition of
"enclosed by a block which associates extensive cleanup
with a transfer of control exception".

Also some reordering of functions in jvm.lisp.

Location:

trunk/abcl/src/org/armedbear/lisp

Files:

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

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

@@ -313 +313 @@
            ;; its cleanup forms.
            (dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*))
-           (let ((protected
-                  (dolist (enclosing-block *blocks*)
-                    (when (eq enclosing-block block)
-                      (return nil))
-                    (when (block-requires-non-local-exit-p enclosing-block)
-                      (return t)))))
+           (let ((protected (enclosed-by-protected-block-p block)))
              (dformat t "p1-return-from protected = ~S~%" protected)
              (when protected
@@ -366 +361 @@
       (cond ((eq (tag-compiland tag) *current-compiland*)
              ;; Does the GO leave an enclosing UNWIND-PROTECT?
-             (let ((protected
-                    (dolist (enclosing-block *blocks*)
-                      (when (eq enclosing-block tag-block)
-                        (return nil))
-                      (when (block-requires-non-local-exit-p enclosing-block)
-                        (return t)))))
-               (when protected
-                 (setf (block-non-local-go-p tag-block) t))))
+             (when (enclosed-by-protected-block-p tag-block)
+               (setf (block-non-local-go-p tag-block) t)))
             (t
              (setf (block-non-local-go-p tag-block) t)))))

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

@@ -4439 +4439 @@
       (compile-progn-body body target representation))))
 
-(defknown find-tag (t) t)
-(defun find-tag (name)
-  (dolist (tag *visible-tags*)
-    (when (eql name (tag-name tag))
-      (return tag))))
-
 (defknown p2-tagbody-node (t t) t)
 (defun p2-tagbody-node (block target)
@@ -4535 +4529 @@
       ;; Local case.
       (let* ((tag-block (tag-block tag))
-             (register nil)
-             (protected
-              ;; Does the GO leave an enclosing CATCH or UNWIND-PROTECT?
-              (dolist (enclosing-block *blocks*)
-                (when (eq enclosing-block tag-block)
-                  (return nil))
-                (when (block-requires-non-local-exit-p enclosing-block)
-                  (return t)))))
-        (unless protected
+             (register nil))
+        (unless (enclosed-by-protected-block-p tag-block)
           (dolist (block *blocks*)
             (if (eq block tag-block)
@@ -4723 +4710 @@
         ;; Local case. Is the RETURN nested inside an UNWIND-PROTECT which is
         ;; inside the block we're returning from?
-        (let ((protected
-               (dolist (enclosing-block *blocks*)
-                 (when (eq enclosing-block block)
-                   (return nil))
-                 (when (block-requires-non-local-exit-p enclosing-block)
-                   (return t)))))
-          (unless protected
-            (unless (compiland-single-valued-p *current-compiland*)
+        (unless (enclosed-by-protected-block-p block)
+          (unless (compiland-single-valued-p *current-compiland*)
 ;;               (format t "compiland not single-valued: ~S~%"
 ;;                       (compiland-name *current-compiland*))
-              (emit-clear-values))
-            (compile-form result-form (block-target block) nil)
-            (emit 'goto (block-exit block))
-            (return-from p2-return-from)))))
+            (emit-clear-values))
+          (compile-form result-form (block-target block) nil)
+          (emit 'goto (block-exit block))
+          (return-from p2-return-from))))
     ;; Non-local RETURN.
     (aver (block-non-local-return-p block))

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

@@ -369 +369 @@
   )
 
+(defvar *blocks* ())
+
+(defun find-block (name)
+  (dolist (block *blocks*)
+    (when (eq name (block-name block))
+      (return block))))
+
 (defknown node-constant-p (t) boolean)
 (defun node-constant-p (object)
@@ -390 +397 @@
   (memq (block-name object) '(CATCH UNWIND-PROTECT)))
 
-(defvar *blocks* ())
-
-(defun find-block (name)
-  (dolist (block *blocks*)
-    (when (eq name (block-name block))
-      (return block))))
+
+(defknown enclosed-by-protected-block-p (&optional outermost-block) boolean)
+(defun enclosed-by-protected-block-p (&optional outermost-block)
+  "Indicates whether the code being compiled/analyzed is enclosed in
+a block which requires a non-local transfer of control exception to
+be generated.
+"
+  (dolist (enclosing-block *blocks*)
+    (when (eq enclosing-block outermost-block)
+      (return-from enclosed-by-protected-block-p nil))
+    (when (block-requires-non-local-exit-p enclosing-block)
+      (return-from enclosed-by-protected-block-p t))))
+
 
 (defstruct tag
@@ -402 +416 @@
   block
   (compiland *current-compiland*))
+
+(defknown find-tag (t) t)
+(defun find-tag (name)
+  (dolist (tag *visible-tags*)
+    (when (eql name (tag-name tag))
+      (return tag))))
 
 (defun process-ignore/ignorable (declaration names variables)