[armedbear-cvs] r13473 - trunk/abcl/src/org/armedbear/lisp
ehuelsmann at common-lisp.net
ehuelsmann at common-lisp.net
Fri Aug 12 22:31:54 UTC 2011
Author: ehuelsmann
Date: Fri Aug 12 15:31:54 2011
New Revision: 13473
Log:
Finally clean up the mess that made up p1-flet and p1-labels,
at the same time speeding up compilation.
Modified:
trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
Modified: trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp
==============================================================================
--- trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 13:39:58 2011 (r13472)
+++ trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp Fri Aug 12 15:31:54 2011 (r13473)
@@ -875,102 +875,89 @@
(defun validate-function-name (name)
(unless (or (symbolp name) (setf-function-name-p name))
- (compiler-error "~S is not a valid function name." name)))
+ (compiler-error "~S is not a valid function name." name))
+ name)
-(defmacro with-local-functions-for-flet/labels
- (form local-functions-var lambda-list-var name-var body-var body1 body2)
- `(let ((*visible-variables* *visible-variables*)
- (*local-functions* *local-functions*)
- (parent-compiland *current-compiland*)
- (,local-functions-var '()))
- (dolist (definition (cadr ,form))
- (let ((,name-var (car definition))
- (,lambda-list-var (cadr definition)))
- (validate-function-name ,name-var)
- (let* ((,body-var (cddr definition))
- (compiland (make-compiland :name ,name-var
- :parent parent-compiland)))
- (push compiland (compiland-children parent-compiland))
- , at body1)))
- (setf ,local-functions-var (nreverse ,local-functions-var))
- ;; Make the local functions visible.
- (dolist (local-function ,local-functions-var)
- (push local-function *local-functions*)
- (let ((variable (local-function-variable local-function)))
- (when variable
- (push variable *visible-variables*))))
- , at body2))
+(defun construct-flet/labels-function (definition variable-name)
+ (let* ((name (car definition))
+ (block-name (fdefinition-block-name (validate-function-name name)))
+ (lambda-list (cadr definition))
+ (compiland (make-compiland :name name :parent *current-compiland*))
+ (local-function (make-local-function :name name :compiland compiland)))
+ (push compiland (compiland-children *current-compiland*))
+ (when variable-name
+ (setf (local-function-variable local-function)
+ (make-variable :name variable-name)))
+ (multiple-value-bind
+ (body decls)
+ (parse-body (cddr definition))
+ (setf (local-function-definition local-function)
+ (copy-tree (cdr definition)))
+ (setf (compiland-lambda-expression compiland)
+ (rewrite-lambda `(lambda ,lambda-list
+ , at decls
+ (block ,block-name
+ , at body)))))
+ local-function))
(defun p1-flet (form)
- (with-local-functions-for-flet/labels
- form local-functions lambda-list name body
- ((let ((local-function (make-local-function :name name
- :compiland compiland))
- (definition (cons lambda-list body)))
- (multiple-value-bind (body decls) (parse-body body)
- (let* ((block-name (fdefinition-block-name name))
- (lambda-expression
- (rewrite-lambda `(lambda ,lambda-list
- , at decls
- (block ,block-name , at body)))))
- (setf (compiland-lambda-expression compiland) lambda-expression)
- (setf (local-function-definition local-function)
- (copy-tree definition))
- (p1-compiland compiland)))
- (push local-function local-functions)))
- ((with-saved-compiler-policy
- (process-optimization-declarations (cddr form))
- (let* ((block (make-flet-node))
- (*block* block)
- (*blocks* (cons block *blocks*))
- (body (cddr form))
- (*visible-variables* *visible-variables*))
- (setf (flet-free-specials block)
- (process-declarations-for-vars body nil block))
- (dolist (special (flet-free-specials block))
- (push special *visible-variables*))
- (let ((body (p1-body (cddr form))))
- (setf (flet-form block)
- (list* (car form)
- (remove-if (lambda (fn)
- (and (inline-p (local-function-name fn))
- (not (local-function-references-needed-p fn))))
- local-functions)
- body)))
- block)))))
+ (let* ((local-functions
+ (mapcar #'(lambda (definition)
+ (construct-flet/labels-function definition nil))
+ (cadr form)))
+ (*local-functions* *local-functions*))
+ (dolist (local-function local-functions)
+ (p1-compiland (local-function-compiland local-function)))
+ (dolist (local-function local-functions)
+ (push local-function *local-functions*))
+ (with-saved-compiler-policy
+ (process-optimization-declarations (cddr form))
+ (let* ((block (make-flet-node))
+ (*block* block)
+ (*blocks* (cons block *blocks*))
+ (body (cddr form))
+ (*visible-variables* *visible-variables*))
+ (setf (flet-free-specials block)
+ (process-declarations-for-vars body nil block))
+ (dolist (special (flet-free-specials block))
+ (push special *visible-variables*))
+ (setf body (p1-body body) ;; affects the outcome of references-needed-p
+ (flet-form block)
+ (list* (car form)
+ (remove-if #'(lambda (fn)
+ (and (inline-p (local-function-name fn))
+ (not (local-function-references-needed-p fn))))
+ local-functions)
+ body))
+ block))))
(defun p1-labels (form)
- (with-local-functions-for-flet/labels
- form local-functions lambda-list name body
- ((let* ((variable (make-variable :name (gensym)))
- (local-function (make-local-function :name name
- :compiland compiland
- :variable variable))
- (block-name (fdefinition-block-name name)))
- (setf (local-function-definition local-function)
- (copy-tree (cons lambda-list body)))
- (multiple-value-bind (body decls) (parse-body body)
- (setf (compiland-lambda-expression compiland)
- (rewrite-lambda
- `(lambda ,lambda-list , at decls (block ,block-name , at body)))))
- (push variable *all-variables*)
- (push local-function local-functions)))
- ((dolist (local-function local-functions)
- (let ((*visible-variables* *visible-variables*))
- (p1-compiland (local-function-compiland local-function))))
- (let* ((block (make-labels-node))
- (*block* block)
- (*blocks* (cons block *blocks*))
- (body (cddr form))
- (*visible-variables* *visible-variables*))
- (setf (labels-free-specials block)
- (process-declarations-for-vars body nil block))
- (dolist (special (labels-free-specials block))
- (push special *visible-variables*))
- (setf (labels-form block)
- (list* (car form) local-functions (p1-body (cddr form))))
- block))))
+ (let* ((local-functions
+ (mapcar #'(lambda (definition)
+ (construct-flet/labels-function definition (gensym)))
+ (cadr form)))
+ (*local-functions* *local-functions*)
+ (*visible-variables* *visible-variables*))
+ (dolist (local-function local-functions)
+ (push local-function *local-functions*)
+ (let ((variable (local-function-variable local-function)))
+ (push variable *all-variables*)
+ (push variable *visible-variables*)))
+ (dolist (local-function local-functions)
+ (p1-compiland (local-function-compiland local-function)))
+ (let* ((block (make-labels-node))
+ (*block* block)
+ (*blocks* (cons block *blocks*))
+ (body (cddr form))
+ (*visible-variables* *visible-variables*))
+ (setf (labels-free-specials block)
+ (process-declarations-for-vars body nil block))
+ (dolist (special (labels-free-specials block))
+ (push special *visible-variables*))
+ (setf (labels-form block)
+ (list* (car form) local-functions (p1-body (cddr form))))
+ block)))
(defknown p1-funcall (t) t)
(defun p1-funcall (form)
More information about the armedbear-cvs
mailing list