Changeset 13473

Timestamp:

08/12/11 22:31:54 (11 years ago)

Author:

ehuelsmann

Message:

Finally clean up the mess that made up p1-flet and p1-labels,
at the same time speeding up compilation.

File:

• trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp (modified) (1 diff)

trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

@@ -876 +876 @@
 (defun validate-function-name (name)
   (unless (or (symbolp name) (setf-function-name-p name))
-    (compiler-error "~S is not a valid function 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*)
+    (compiler-error "~S is not a valid function name." name))
+  name)
+
+(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
+                               ,@decls
+                               (block ,block-name
+                                 ,@body)))))
+    local-function))
+
+(defun p1-flet (form)
+  (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)
+  (let* ((local-functions
+          (mapcar #'(lambda (definition)
+                      (construct-flet/labels-function definition (gensym)))
+                  (cadr form)))
          (*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))
-           ,@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*))))
-     ,@body2))
-
-(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
-                                      ,@decls
-                                      (block ,block-name ,@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)))))
-
-
-(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 ,@decls (block ,block-name ,@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))))
+         (*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)