[armedbear-cvs] r11819 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sun May 3 08:46:39 UTC 2009
Author: ehuelsmann
Date: Sun May 3 04:46:39 2009
New Revision: 11819
Log:
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.
Modified:
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
trunk/abcl/src/org/armedbear/lisp/jvm.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Sun May 3 04:46:39 2009
@@ -312,12 +312,7 @@
;; local return anyway so that UNWIND-PROTECT can catch it and run
;; 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
(setf (block-non-local-return-p block) t))))
@@ -365,14 +360,8 @@
(let ((tag-block (tag-block tag)))
(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)))))
form)
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass2.lisp Sun May 3 04:46:39 2009
@@ -4438,12 +4438,6 @@
(process-optimization-declarations body)
(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)
(let* ((*blocks* (cons block *blocks*))
@@ -4534,15 +4528,8 @@
(when (eq (tag-compiland tag) *current-compiland*)
;; 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)
(return)
@@ -4722,20 +4709,14 @@
(when (eq (block-compiland block) compiland)
;; 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))
(cond ((node-constant-p result-form)
Modified: trunk/abcl/src/org/armedbear/lisp/jvm.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/jvm.lisp (original)
+++ trunk/abcl/src/org/armedbear/lisp/jvm.lisp Sun May 3 04:46:39 2009
@@ -368,6 +368,13 @@
free-specials
)
+(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)
(cond ((block-node-p object)
@@ -389,12 +396,19 @@
"
(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
name
@@ -402,6 +416,12 @@
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)
(when (memq declaration '(IGNORE IGNORABLE))
(let ((what (if (eq declaration 'IGNORE) "ignored" "ignorable")))
More information about the armedbear-cvs
mailing list