[armedbear-cvs] r12123 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Fri Aug 28 09:04:49 UTC 2009
Author: ehuelsmann
Date: Fri Aug 28 05:04:44 2009
New Revision: 12123
Log:
Convert LET BLOCK-NODEs to LET/LET*-NODEs and
clean up the BLOCK-NODE structure to serve BLOCKs only.
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 Fri Aug 28 05:04:44 2009
@@ -200,8 +200,7 @@
(defun p1-let/let* (form)
(declare (type cons form))
(let* ((*visible-variables* *visible-variables*)
- (block (make-block-node '(LET)))
- (*blocks* (cons block *blocks*))
+ (block (make-let/let*-node))
(op (%car form))
(varlist (cadr form))
(body (cddr form)))
@@ -222,18 +221,19 @@
(dolist (variable vars)
(when (special-variable-p (variable-name variable))
(setf (variable-special-p variable) t
- (block-environment-register block) t)))
+ (let-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)
+ (setf (let-free-specials block)
(process-declarations-for-vars body (reverse vars) block))
- (setf (block-vars block) vars)
+ (setf (let-vars block) vars)
;; Make free specials visible.
- (dolist (variable (block-free-specials block))
+ (dolist (variable (let-free-specials block))
(push variable *visible-variables*)))
- (setf body (p1-body body))
- (setf (block-form block) (list* op varlist body))
+ (let ((*blocks* (cons block *blocks*)))
+ (setf body (p1-body body)))
+ (setf (let-form block) (list* op varlist body))
block))
(defun p1-locally (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 Fri Aug 28 05:04:44 2009
@@ -4072,7 +4072,7 @@
(defun propagate-vars (block)
(let ((removed '()))
- (dolist (variable (block-vars block))
+ (dolist (variable (let-vars block))
(unless (or (variable-special-p variable)
(variable-closure-index variable))
(when (eql (variable-writes variable) 0)
@@ -4104,7 +4104,7 @@
'sys::dotimes-limit-variable-p)
(let* ((symbol (get (variable-name variable)
'sys::dotimes-index-variable-name))
- (index-variable (find-variable symbol (block-vars block))))
+ (index-variable (find-variable symbol (let-vars block))))
(when index-variable
(setf (get (variable-name index-variable)
'sys::dotimes-limit-variable-name)
@@ -4119,7 +4119,7 @@
(push variable removed)))))))
(when removed
(dolist (variable removed)
- (setf (block-vars block) (remove variable (block-vars block)))))))
+ (setf (let-vars block) (remove variable (let-vars block)))))))
(defun derive-variable-representation (variable block
&key (type nil type-supplied-p))
@@ -4156,7 +4156,7 @@
'sys::dotimes-limit-variable-name))
(limit-variable (and name
(or (find-variable name
- (block-vars block))
+ (let-vars block))
(find-visible-variable name)))))
(when limit-variable
(derive-variable-representation limit-variable block)
@@ -4264,7 +4264,7 @@
(defknown p2-let-bindings (t) t)
(defun p2-let-bindings (block)
- (dolist (variable (block-vars block))
+ (dolist (variable (let-vars block))
(unless (or (variable-special-p variable)
(variable-closure-index variable)
(zerop (variable-reads variable)))
@@ -4279,7 +4279,7 @@
;; been evaluated. Note that we can't just push the values on the stack
;; because we'll lose JVM stack consistency if there is a non-local
;; transfer of control from one of the initforms.
- (dolist (variable (block-vars block))
+ (dolist (variable (let-vars block))
(let* ((initform (variable-initform variable))
(unused-p (and (not (variable-special-p variable))
;; If it's never read, we don't care about writes.
@@ -4320,7 +4320,7 @@
(aload (car temp))
(compile-binding (cdr temp))))
;; Now make the variables visible.
- (dolist (variable (block-vars block))
+ (dolist (variable (let-vars block))
(push variable *visible-variables*))
t)
@@ -4329,7 +4329,7 @@
(let ((must-clear-values nil))
(declare (type boolean must-clear-values))
;; Generate code to evaluate initforms and bind variables.
- (dolist (variable (block-vars block))
+ (dolist (variable (let-vars block))
(let* ((initform (variable-initform variable))
(unused-p (and (not (variable-special-p variable))
(zerop (variable-reads variable))
@@ -4401,14 +4401,14 @@
t)
(defun p2-let/let*-node (block target representation)
- (let* ((*blocks* (cons block *blocks*))
+ (let* (
(*register* *register*)
- (form (block-form block))
+ (form (let-form block))
(*visible-variables* *visible-variables*)
(specialp nil)
(label-START (gensym)))
;; Walk the variable list looking for special bindings and unused lexicals.
- (dolist (variable (block-vars block))
+ (dolist (variable (let-vars block))
(cond ((variable-special-p variable)
(setf specialp t))
((zerop (variable-reads variable))
@@ -4416,8 +4416,8 @@
;; If there are any special bindings...
(when specialp
;; We need to save current dynamic environment.
- (setf (block-environment-register block) (allocate-register))
- (save-dynamic-environment (block-environment-register block))
+ (setf (let-environment-register block) (allocate-register))
+ (save-dynamic-environment (let-environment-register block))
(label label-START))
(propagate-vars block)
(ecase (car form)
@@ -4426,14 +4426,15 @@
(LET*
(p2-let*-bindings block)))
;; Make declarations of free specials visible.
- (dolist (variable (block-free-specials block))
+ (dolist (variable (let-free-specials block))
(push variable *visible-variables*))
;; Body of LET/LET*.
(with-saved-compiler-policy
(process-optimization-declarations (cddr form))
- (compile-progn-body (cddr form) target representation))
+ (let ((*blocks* (cons block *blocks*)))
+ (compile-progn-body (cddr form) target representation)))
(when specialp
- (restore-environment-and-make-handler (block-environment-register block)
+ (restore-environment-and-make-handler (let-environment-register block)
label-START))))
(defknown p2-locally-node (t t t) t)
@@ -7907,23 +7908,12 @@
(aver nil))))
((var-ref-p form)
(compile-var-ref form target representation))
- ((block-node-p form)
- (let ((name (block-name form)))
- (if (not (consp name))
- (p2-block-node form target representation)
- (let ((name (car name)))
- (cond
- ((eq name 'LET)
- (p2-let/let*-node form target representation))
- ((eq name 'SETF) ;; SETF functions create
- ;; consp block names, if we're unlucky
- (p2-block-node form target representation))
- (t
- (print name)
- (aver (not "Can't happen.")))
- )))))
((node-p form)
(cond
+ ((block-node-p form)
+ (p2-block-node form target representation))
+ ((let/let*-node-p form)
+ (p2-let/let*-node form target representation))
((tagbody-node-p form)
(p2-tagbody-node form target)
(fix-boxing representation nil))
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 Fri Aug 28 05:04:44 2009
@@ -438,13 +438,7 @@
;; True if there is any RETURN from this block.
return-p
;; True if there is a non-local RETURN from this block.
- non-local-return-p
- ;; If non-nil, register containing saved dynamic environment for this block.
- environment-register
- ;; Only used in LET/LET*/M-V-B nodes.
- vars
- free-specials
- )
+ non-local-return-p)
(defvar *blocks* ())
@@ -481,9 +475,7 @@
"
(or (unwind-protect-node-p object)
(catch-node-p object)
- (synchronized-node-p object)
- (and (block-node-p object)
- (equal (block-name object) '(THREADS:SYNCHRONIZED-ON)))))
+ (synchronized-node-p object)))
(defknown enclosed-by-protected-block-p (&optional t) boolean)
@@ -503,10 +495,8 @@
(dolist (enclosing-block *blocks*)
(when (eq enclosing-block outermost-block)
(return nil))
- (when (or (and (binding-node-p enclosing-block)
- (binding-node-environment-register enclosing-block))
- (and (block-node-p enclosing-block)
- (block-environment-register enclosing-block)))
+ (when (and (binding-node-p enclosing-block)
+ (binding-node-environment-register enclosing-block))
(return t))))
(defknown environment-register-to-restore (&optional t) t)
@@ -520,8 +510,6 @@
(return-from environment-register-to-restore last-register))
(or (and (binding-node-p block)
(binding-node-environment-register block))
- (and (block-node-p block)
- (block-environment-register block))
last-register)))
(reduce #'outermost-register *blocks*
:initial-value nil)))
More information about the armedbear-cvs
mailing list