[armedbear-cvs] r11833 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Tue May 5 21:42:22 UTC 2009
Author: ehuelsmann
Date: Tue May 5 17:42:17 2009
New Revision: 11833
Log:
Special bindings fixes:
compiler-pass1.lisp: set BLOCK-ENVIRONMENT-REGISTER to T,
for ENCLOSED-BY-ENVIRONMENT-SETTING-BLOCK-P to find.
p1-progv: correctness; the symbol and values forms are
outside of the progv-block-scope
p2-progv-node: from p2-progv. A node is required to
indicate to code inside the PROGV scope that bindings
restoration is in order
p1-return-from: indicate to the associated block that
a RETURN-FROM instruction will want to
p2-block-node: p2-progv-node doesn't register variables,
yet it does require a block restoration. Now that
PROGV uses a block (with an environment-register!)
it's incorrect to look at *all-variables*.
... and a little bit of re-indenting.
Modified:
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
trunk/abcl/src/org/armedbear/lisp/compiler-pass2.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 Tue May 5 17:42:17 2009
@@ -210,11 +210,13 @@
;; Check for globally declared specials.
(dolist (variable vars)
(when (special-variable-p (variable-name variable))
- (setf (variable-special-p variable) t)))
+ (setf (variable-special-p variable) t
+ (block-environment-register block) t)))
;; For processing declarations, we want to walk the variable list from
;; last to first, since declarations apply to the last-defined variable
;; with the specified name.
- (setf (block-free-specials block) (process-declarations-for-vars body (reverse vars)))
+ (setf (block-free-specials block)
+ (process-declarations-for-vars body (reverse vars)))
(setf (block-vars block) vars)
;; Make free specials visible.
(dolist (variable (block-free-specials block))
@@ -255,8 +257,10 @@
;; Check for globally declared specials.
(dolist (variable vars)
(when (special-variable-p (variable-name variable))
- (setf (variable-special-p variable) t)))
- (setf (block-free-specials block) (process-declarations-for-vars body vars))
+ (setf (variable-special-p variable) t
+ (block-environment-register block) t)))
+ (setf (block-free-specials block)
+ (process-declarations-for-vars body vars))
(setf (block-vars block) (nreverse vars)))
(setf body (p1-body body))
(setf (block-form block) (list* 'MULTIPLE-VALUE-BIND varlist values-form body))
@@ -324,8 +328,13 @@
(dformat t "*blocks* = ~S~%" (mapcar #'block-name *blocks*))
(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))))
+ (if protected
+ (setf (block-non-local-return-p block) t)
+ ;; non-local GO's ensure environment restoration
+ ;; find out about this local GO
+ (when (null (block-needs-environment-restoration block))
+ (setf (block-needs-environment-restoration block)
+ (enclosed-by-environment-setting-block-p block))))))
(t
(setf (block-non-local-return-p block) t)))
(when (block-non-local-return-p block)
@@ -374,7 +383,7 @@
(setf (tag-used tag) t)
(let ((tag-block (tag-block tag)))
(cond ((eq (tag-compiland tag) *current-compiland*)
- ;; Does the GO leave an enclosing UNWIND-PROTECT?
+ ;; Does the GO leave an enclosing UNWIND-PROTECT or CATCH?
(if (enclosed-by-protected-block-p tag-block)
(setf (block-non-local-go-p tag-block) t)
;; non-local GO's ensure environment restoration
@@ -710,10 +719,15 @@
(let ((new-form (rewrite-progv form)))
(when (neq new-form form)
(return-from p1-progv (p1 new-form))))
- (let ((symbols-form (cadr form))
- (values-form (caddr form))
- (body (cdddr form)))
- `(progv ,(p1 symbols-form) ,(p1 values-form) ,@(p1-body body))))
+ (let* ((symbols-form (p1 (cadr form)))
+ (values-form (p1 (caddr form)))
+ (block (make-block-node '(PROGV)))
+ (*blocks* (cons block *blocks*))
+ (body (cdddr form)))
+ (setf (block-form block)
+ `(progv ,symbols-form ,values-form ,@(p1-body body))
+ (block-environment-register block) t)
+ block))
(defknown rewrite-progv (t) t)
(defun rewrite-progv (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 Tue May 5 17:42:17 2009
@@ -4635,13 +4635,12 @@
(cond ((block-return-p block)
(setf (block-target block) target)
(dformat t "p2-block-node lastSpecialBinding~%")
- (dformat t "*all-variables* = ~S~%" (mapcar #'variable-name *all-variables*))
- (cond ((some #'variable-special-p *all-variables*)
- ;; Save the current dynamic environment.
- (setf (block-environment-register block) (allocate-register))
- (save-dynamic-environment (block-environment-register block)))
- (t
- (dformat t "no specials~%")))
+ (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*)
(BEGIN-BLOCK (gensym))
@@ -4785,11 +4784,13 @@
(t
(compile-constant (eval (second form)) target representation))))
-(defun p2-progv (form target representation)
- (let* ((symbols-form (cadr form))
+(defun p2-progv-node (block target representation)
+ (let* ((form (block-form block))
+ (symbols-form (cadr form))
(values-form (caddr form))
(*register* *register*)
- (environment-register (allocate-register))
+ (environment-register
+ (setf (block-environment-register block) (allocate-register)))
(label-START (gensym))
(label-END (gensym))
(label-EXIT (gensym)))
@@ -4804,12 +4805,13 @@
(emit-push-current-thread)
(emit-invokestatic +lisp-class+ "progvBindVars"
(list +lisp-object+ +lisp-object+ +lisp-thread+) nil)
- ;; Implicit PROGN.
- (compile-progn-body (cdddr form) target)
- (emit 'goto label-EXIT)
- (label label-END)
- (restore-dynamic-environment environment-register)
- (emit 'athrow)
+ ;; Implicit PROGN.
+ (let ((*blocks* (cons block *blocks*)))
+ (compile-progn-body (cdddr form) target)
+ (emit 'goto label-EXIT)
+ (label label-END)
+ (restore-dynamic-environment environment-register)
+ (emit 'athrow))
;; Restore dynamic environment.
(label label-EXIT)
@@ -7938,30 +7940,22 @@
((block-node-p form)
(cond ((equal (block-name form) '(TAGBODY))
(p2-tagbody-node form target)
- (fix-boxing representation nil)
- )
+ (fix-boxing representation nil))
((equal (block-name form) '(LET))
- (p2-let/let*-node form target representation)
-;; (fix-boxing representation nil)
- )
+ (p2-let/let*-node form target representation))
((equal (block-name form) '(MULTIPLE-VALUE-BIND))
(p2-m-v-b-node form target)
- (fix-boxing representation nil)
- )
+ (fix-boxing representation nil))
((equal (block-name form) '(UNWIND-PROTECT))
(p2-unwind-protect-node form target)
- (fix-boxing representation nil)
- )
+ (fix-boxing representation nil))
((equal (block-name form) '(CATCH))
(p2-catch-node form target)
- (fix-boxing representation nil)
- )
+ (fix-boxing representation nil))
+ ((equal (block-name form) '(PROGV))
+ (p2-progv-node form target representation))
(t
- (p2-block-node form target representation)
-;; (fix-boxing representation nil)
- ))
-;; (fix-boxing representation nil)
- )
+ (p2-block-node form target representation))))
((constantp form)
(compile-constant form target representation))
(t
@@ -8708,7 +8702,6 @@
(install-p2-handler 'null 'p2-not/null)
(install-p2-handler 'or 'p2-or)
(install-p2-handler 'packagep 'p2-packagep)
- (install-p2-handler 'progv 'p2-progv)
(install-p2-handler 'puthash 'p2-puthash)
(install-p2-handler 'quote 'p2-quote)
(install-p2-handler 'read-line 'p2-read-line)
More information about the armedbear-cvs
mailing list