[armedbear-cvs] r12086 - trunk/abcl/src/org/armedbear/lisp
Erik Huelsmann
ehuelsmann at common-lisp.net
Sat Aug 8 15:20:29 UTC 2009
Author: ehuelsmann
Date: Sat Aug 8 11:20:28 2009
New Revision: 12086
Log:
Make every form which may contain free specials declarations a BLOCK-NODE.
LOCALLY, FLET and LABELS were not converted to blocks - yet.
While at it, change the block dispatch routine: we're not smart enough to
detect that the (block-name form) form will generate the same value every
time - so we don't cache the function result, but evaluate it each time.
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 Sat Aug 8 11:20:28 2009
@@ -233,13 +233,17 @@
block))
(defun p1-locally (form)
- (let ((*visible-variables* *visible-variables*)
- (specials (process-special-declarations (cdr form))))
- (dolist (name specials)
+ (let* ((*visible-variables* *visible-variables*)
+ (block (make-block-node '(LOCALLY)))
+ (free-specials (process-declarations-for-vars (cdr form) nil)))
+ (setf (block-free-specials block) free-specials)
+ (dolist (special free-specials)
;; (format t "p1-locally ~S is special~%" name)
- (push (make-variable :name name :special-p t) *visible-variables*))
- (setf (cdr form) (p1-body (cdr form)))
- form))
+ (push special *visible-variables*))
+ (let ((*blocks* (cons block *blocks*)))
+ (setf (block-form block)
+ (list* 'LOCALLY (p1-body (cdr form))))
+ block)))
(defknown p1-m-v-b (t) t)
(defun p1-m-v-b (form)
@@ -631,7 +635,17 @@
(push local-function local-functions)))
((with-saved-compiler-policy
(process-optimization-declarations (cddr form))
- (list* (car form) local-functions (p1-body (cddr form)))))))
+ (let* ((block (make-block-node '(FLET)))
+ (*blocks* (cons block *blocks*))
+ (body (cddr form))
+ (*visible-variables* *visible-variables*))
+ (setf (block-free-specials block)
+ (process-declarations-for-vars body nil))
+ (dolist (special (block-free-specials block))
+ (push special *visible-variables*))
+ (setf (block-form block)
+ (list* (car form) local-functions (p1-body (cddr form))))
+ block)))))
(defun p1-labels (form)
@@ -651,7 +665,17 @@
(let ((*visible-variables* *visible-variables*)
(*current-compiland* (local-function-compiland local-function)))
(p1-compiland (local-function-compiland local-function))))
- (list* (car form) local-functions (p1-body (cddr form))))))
+ (let* ((block (make-block-node '(LABELS)))
+ (*blocks* (cons block *blocks*))
+ (body (cddr form))
+ (*visible-variables* *visible-variables*))
+ (setf (block-free-specials block)
+ (process-declarations-for-vars body nil))
+ (dolist (special (block-free-specials block))
+ (push special *visible-variables*))
+ (setf (block-form block)
+ (list* (car form) local-functions (p1-body (cddr form))))
+ block))))
(defknown p1-funcall (t) t)
(defun p1-funcall (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 Sat Aug 8 11:20:28 2009
@@ -4436,13 +4436,13 @@
(restore-environment-and-make-handler (block-environment-register block)
label-START))))
-(defun p2-locally (form target representation)
+(defknown p2-locally-node (t t t) t)
+(defun p2-locally-node (block target representation)
(with-saved-compiler-policy
- (let* ((body (cdr form))
- (*visible-variables* *visible-variables*)
- (specials (process-special-declarations body)))
- (dolist (name specials)
- (push (make-variable :name name :special-p t) *visible-variables*))
+ (let* ((body (cdr (block-form block)))
+ (*visible-variables* (append (block-free-specials block)
+ *visible-variables*))
+ (*blocks* (cons block *blocks*)))
(process-optimization-declarations body)
(compile-progn-body body target representation))))
@@ -4952,26 +4952,28 @@
(emit-make-compiled-closure-for-flet/labels
local-function compiland g)))))))
-(defknown p2-flet (t t t) t)
-(defun p2-flet (form target representation)
- (let ((*local-functions* *local-functions*)
- (*visible-variables* *visible-variables*)
- (local-functions (cadr form))
- (body (cddr form)))
+(defknown p2-flet-node (t t t) t)
+(defun p2-flet-node (block target representation)
+ (let* ((form (block-form block))
+ (*local-functions* *local-functions*)
+ (*visible-variables* *visible-variables*)
+ (local-functions (cadr form))
+ (body (cddr form)))
(dolist (local-function local-functions)
(p2-flet-process-compiland local-function))
(dolist (local-function local-functions)
(push local-function *local-functions*))
- (dolist (special (process-special-declarations body))
- (push (make-variable :name special :special-p t) *visible-variables*))
+ (dolist (special (block-free-specials block))
+ (push special *visible-variables*))
(compile-progn-body body target representation)))
-(defknown p2-labels (t t t) t)
-(defun p2-labels (form target representation)
- (let ((*local-functions* *local-functions*)
- (*visible-variables* *visible-variables*)
- (local-functions (cadr form))
- (body (cddr form)))
+(defknown p2-labels-node (t t t) t)
+(defun p2-labels-node (block target representation)
+ (let* ((form (block-form block))
+ (*local-functions* *local-functions*)
+ (*visible-variables* *visible-variables*)
+ (local-functions (cadr form))
+ (body (cddr form)))
(dolist (local-function local-functions)
(push local-function *local-functions*)
(push (local-function-variable local-function) *visible-variables*))
@@ -4982,8 +4984,8 @@
(setf (variable-register variable) (allocate-register)))))
(dolist (local-function local-functions)
(p2-labels-process-compiland local-function))
- (dolist (special (process-special-declarations body))
- (push (make-variable :name special :special-p t) *visible-variables*))
+ (dolist (special (block-free-specials block))
+ (push special *visible-variables*))
(compile-progn-body body target representation)))
(defun p2-lambda (compiland target)
@@ -7901,27 +7903,35 @@
((var-ref-p form)
(compile-var-ref form target representation))
((block-node-p form)
- (cond ((equal (block-name form) '(TAGBODY))
- (p2-tagbody-node form target)
- (fix-boxing representation nil))
- ((equal (block-name form) '(LET))
- (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))
- ((equal (block-name form) '(UNWIND-PROTECT))
- (p2-unwind-protect-node form target)
- (fix-boxing representation nil))
- ((equal (block-name form) '(CATCH))
- (p2-catch-node form target)
- (fix-boxing representation nil))
- ((equal (block-name form) '(PROGV))
- (p2-progv-node form target representation))
- ((equal (block-name form) '(THREADS:SYNCHRONIZED-ON))
- (p2-threads-synchronized-on form target)
- (fix-boxing representation nil))
- (t
- (p2-block-node form target representation))))
+ (let ((name (block-name form)))
+ (if (not (consp name))
+ (p2-block-node form target representation)
+ (let ((name (car name)))
+ (cond ((eq name 'TAGBODY)
+ (p2-tagbody-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'LET)
+ (p2-let/let*-node form target representation))
+ ((eq name 'FLET)
+ (p2-flet-node form target representation))
+ ((eq name 'LABELS)
+ (p2-labels-node form target representation))
+ ((eq name 'MULTIPLE-VALUE-BIND)
+ (p2-m-v-b-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'UNWIND-PROTECT)
+ (p2-unwind-protect-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'CATCH)
+ (p2-catch-node form target)
+ (fix-boxing representation nil))
+ ((eq name 'PROGV)
+ (p2-progv-node form target representation))
+ ((eq name 'LOCALLY)
+ (p2-locally-node form target representation))
+ ((eq name 'THREADS:SYNCHRONIZED-ON)
+ (p2-threads-synchronized-on form target)
+ (fix-boxing representation nil)))))))
((constantp form)
(compile-constant form target representation))
(t
@@ -8596,7 +8606,6 @@
(install-p2-handler 'eval-when 'p2-eval-when)
(install-p2-handler 'find-class 'p2-find-class)
(install-p2-handler 'fixnump 'p2-fixnump)
- (install-p2-handler 'flet 'p2-flet)
(install-p2-handler 'funcall 'p2-funcall)
(install-p2-handler 'function 'p2-function)
(install-p2-handler 'gensym 'p2-gensym)
@@ -8606,14 +8615,12 @@
(install-p2-handler 'gethash1 'p2-gethash)
(install-p2-handler 'go 'p2-go)
(install-p2-handler 'if 'p2-if)
- (install-p2-handler 'labels 'p2-labels)
(install-p2-handler 'length 'p2-length)
(install-p2-handler 'list 'p2-list)
(install-p2-handler 'sys::backq-list 'p2-list)
(install-p2-handler 'list* 'p2-list*)
(install-p2-handler 'sys::backq-list* 'p2-list*)
(install-p2-handler 'load-time-value 'p2-load-time-value)
- (install-p2-handler 'locally 'p2-locally)
(install-p2-handler 'logand 'p2-logand)
(install-p2-handler 'logior 'p2-logior)
(install-p2-handler 'lognot 'p2-lognot)
More information about the armedbear-cvs
mailing list