Ignore:
Timestamp:
08/12/11 22:31:54 (10 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:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/compiler-pass1.lisp

    r13472 r13473  
    876876(defun validate-function-name (name)
    877877  (unless (or (symbolp name) (setf-function-name-p name))
    878     (compiler-error "~S is not a valid function name." name)))
    879 
    880 (defmacro with-local-functions-for-flet/labels
    881     (form local-functions-var lambda-list-var name-var body-var body1 body2)
    882   `(let ((*visible-variables* *visible-variables*)
     878    (compiler-error "~S is not a valid function name." name))
     879  name)
     880
     881(defun construct-flet/labels-function (definition variable-name)
     882  (let* ((name (car definition))
     883         (block-name (fdefinition-block-name (validate-function-name name)))
     884         (lambda-list (cadr definition))
     885         (compiland (make-compiland :name name :parent *current-compiland*))
     886         (local-function (make-local-function :name name :compiland compiland)))
     887    (push compiland (compiland-children *current-compiland*))
     888    (when variable-name
     889      (setf (local-function-variable local-function)
     890            (make-variable :name variable-name)))
     891    (multiple-value-bind
     892          (body decls)
     893        (parse-body (cddr definition))
     894      (setf (local-function-definition local-function)
     895            (copy-tree (cdr definition)))
     896      (setf (compiland-lambda-expression compiland)
     897            (rewrite-lambda `(lambda ,lambda-list
     898                               ,@decls
     899                               (block ,block-name
     900                                 ,@body)))))
     901    local-function))
     902
     903(defun p1-flet (form)
     904  (let* ((local-functions
     905          (mapcar #'(lambda (definition)
     906                      (construct-flet/labels-function definition nil))
     907                  (cadr form)))
     908         (*local-functions* *local-functions*))
     909    (dolist (local-function local-functions)
     910      (p1-compiland (local-function-compiland local-function)))
     911    (dolist (local-function local-functions)
     912      (push local-function *local-functions*))
     913    (with-saved-compiler-policy
     914        (process-optimization-declarations (cddr form))
     915      (let* ((block (make-flet-node))
     916             (*block* block)
     917             (*blocks* (cons block *blocks*))
     918             (body (cddr form))
     919             (*visible-variables* *visible-variables*))
     920        (setf (flet-free-specials block)
     921              (process-declarations-for-vars body nil block))
     922        (dolist (special (flet-free-specials block))
     923          (push special *visible-variables*))
     924        (setf body (p1-body body) ;; affects the outcome of references-needed-p
     925              (flet-form block)
     926              (list* (car form)
     927                     (remove-if #'(lambda (fn)
     928                                    (and (inline-p (local-function-name fn))
     929                                         (not (local-function-references-needed-p fn))))
     930                                local-functions)
     931                     body))
     932        block))))
     933
     934
     935(defun p1-labels (form)
     936  (let* ((local-functions
     937          (mapcar #'(lambda (definition)
     938                      (construct-flet/labels-function definition (gensym)))
     939                  (cadr form)))
    883940         (*local-functions* *local-functions*)
    884          (parent-compiland *current-compiland*)
    885          (,local-functions-var '()))
    886      (dolist (definition (cadr ,form))
    887        (let ((,name-var (car definition))
    888              (,lambda-list-var (cadr definition)))
    889          (validate-function-name ,name-var)
    890          (let* ((,body-var (cddr definition))
    891                 (compiland (make-compiland :name ,name-var
    892                                            :parent parent-compiland)))
    893            (push compiland (compiland-children parent-compiland))
    894            ,@body1)))
    895      (setf ,local-functions-var (nreverse ,local-functions-var))
    896      ;; Make the local functions visible.
    897      (dolist (local-function ,local-functions-var)
    898        (push local-function *local-functions*)
    899        (let ((variable (local-function-variable local-function)))
    900          (when variable
    901            (push variable *visible-variables*))))
    902      ,@body2))
    903 
    904 (defun p1-flet (form)
    905   (with-local-functions-for-flet/labels
    906       form local-functions lambda-list name body
    907       ((let ((local-function (make-local-function :name name
    908                                                   :compiland compiland))
    909        (definition (cons lambda-list body)))
    910    (multiple-value-bind (body decls) (parse-body body)
    911      (let* ((block-name (fdefinition-block-name name))
    912       (lambda-expression
    913        (rewrite-lambda `(lambda ,lambda-list
    914                                       ,@decls
    915                                       (block ,block-name ,@body)))))
    916        (setf (compiland-lambda-expression compiland) lambda-expression)
    917        (setf (local-function-definition local-function)
    918        (copy-tree definition))
    919        (p1-compiland compiland)))
    920    (push local-function local-functions)))
    921       ((with-saved-compiler-policy
    922    (process-optimization-declarations (cddr form))
    923    (let* ((block (make-flet-node))
    924     (*block* block)
    925     (*blocks* (cons block *blocks*))
    926     (body (cddr form))
    927     (*visible-variables* *visible-variables*))
    928      (setf (flet-free-specials block)
    929      (process-declarations-for-vars body nil block))
    930      (dolist (special (flet-free-specials block))
    931        (push special *visible-variables*))
    932            (let ((body (p1-body (cddr form))))
    933              (setf (flet-form block)
    934                    (list* (car form)
    935                           (remove-if (lambda (fn)
    936                                        (and (inline-p (local-function-name fn))
    937                                             (not (local-function-references-needed-p fn))))
    938                                      local-functions)
    939                           body)))
    940            block)))))
    941 
    942 
    943 (defun p1-labels (form)
    944   (with-local-functions-for-flet/labels
    945       form local-functions lambda-list name body
    946       ((let* ((variable (make-variable :name (gensym)))
    947         (local-function (make-local-function :name name
    948                :compiland compiland
    949                :variable variable))
    950               (block-name (fdefinition-block-name name)))
    951    (setf (local-function-definition local-function)
    952          (copy-tree (cons lambda-list body)))
    953    (multiple-value-bind (body decls) (parse-body body)
    954      (setf (compiland-lambda-expression compiland)
    955                  (rewrite-lambda
    956      `(lambda ,lambda-list ,@decls (block ,block-name ,@body)))))
    957    (push variable *all-variables*)
    958    (push local-function local-functions)))
    959       ((dolist (local-function local-functions)
    960    (let ((*visible-variables* *visible-variables*))
    961      (p1-compiland (local-function-compiland local-function))))
    962        (let* ((block (make-labels-node))
    963         (*block* block)
    964               (*blocks* (cons block *blocks*))
    965               (body (cddr form))
    966               (*visible-variables* *visible-variables*))
    967          (setf (labels-free-specials block)
    968                (process-declarations-for-vars body nil block))
    969          (dolist (special (labels-free-specials block))
    970            (push special *visible-variables*))
    971          (setf (labels-form block)
    972                (list* (car form) local-functions (p1-body (cddr form))))
    973          block))))
     941         (*visible-variables* *visible-variables*))
     942    (dolist (local-function local-functions)
     943      (push local-function *local-functions*)
     944      (let ((variable (local-function-variable local-function)))
     945        (push variable *all-variables*)
     946        (push variable *visible-variables*)))
     947    (dolist (local-function local-functions)
     948      (p1-compiland (local-function-compiland local-function)))
     949    (let* ((block (make-labels-node))
     950           (*block* block)
     951           (*blocks* (cons block *blocks*))
     952           (body (cddr form))
     953           (*visible-variables* *visible-variables*))
     954      (setf (labels-free-specials block)
     955            (process-declarations-for-vars body nil block))
     956      (dolist (special (labels-free-specials block))
     957        (push special *visible-variables*))
     958      (setf (labels-form block)
     959            (list* (car form) local-functions (p1-body (cddr form))))
     960      block)))
    974961
    975962(defknown p1-funcall (t) t)
Note: See TracChangeset for help on using the changeset viewer.