(setf (component-reanalyze component) nil)
(let ((head (component-head component)))
(do ()
- ((dolist (ep (block-succ head) t)
- (unless (or (block-flag ep) (block-delete-p ep))
- (find-dfo-aux ep head component)
- (return nil))))))
+ ((dolist (ep (block-succ head) t)
+ (unless (or (block-flag ep) (block-delete-p ep))
+ (find-dfo-aux ep head component)
+ (return nil))))))
(let ((num 0))
(declare (fixnum num))
(do-blocks-backwards (block component :both)
(if (block-flag block)
- (setf (block-number block) (incf num))
- (delete-block-lazily block)))
+ (setf (block-number block) (incf num))
+ (delete-block-lazily block)))
(clean-component component (component-head component)))
(values))
(defun join-components (new old)
(aver (eq (component-kind new) (component-kind old)))
(let ((old-head (component-head old))
- (old-tail (component-tail old))
- (head (component-head new))
- (tail (component-tail new)))
+ (old-tail (component-tail old))
+ (head (component-head new))
+ (tail (component-tail new)))
(do-blocks (block old)
(setf (block-flag block) nil)
(setf (block-component block) new))
(let ((old-next (block-next old-head))
- (old-last (block-prev old-tail))
- (next (block-next head)))
+ (old-last (block-prev old-tail))
+ (next (block-next head)))
(unless (eq old-next old-tail)
- (setf (block-next head) old-next)
- (setf (block-prev old-next) head)
+ (setf (block-next head) old-next)
+ (setf (block-prev old-next) head)
- (setf (block-prev next) old-last)
- (setf (block-next old-last) next))
+ (setf (block-prev next) old-last)
+ (setf (block-next old-last) next))
(setf (block-next old-head) old-tail)
(setf (block-prev old-tail) old-head))
(setf (component-lambdas new)
- (nconc (component-lambdas old) (component-lambdas new)))
+ (nconc (component-lambdas old) (component-lambdas new)))
(setf (component-lambdas old) nil)
(setf (component-new-functionals new)
- (nconc (component-new-functionals old)
- (component-new-functionals new)))
+ (nconc (component-new-functionals old)
+ (component-new-functionals new)))
(setf (component-new-functionals old) nil)
(dolist (xp (block-pred old-tail))
(declare (type cblock block) (type component component))
(let ((home-lambda (block-home-lambda block)))
(if (eq (functional-kind home-lambda) :deleted)
- component
- (let ((home-component (lambda-component home-lambda)))
- (cond ((eq (component-kind home-component) :initial)
- (dfo-scavenge-dependency-graph home-lambda component))
- ((eq home-component component)
- component)
- (t
- (join-components home-component component)
- home-component))))))
+ component
+ (let ((home-component (lambda-component home-lambda)))
+ (cond ((eq (component-kind home-component) :initial)
+ (dfo-scavenge-dependency-graph home-lambda component))
+ ((eq home-component component)
+ component)
+ (t
+ (join-components home-component component)
+ home-component))))))
;;; This is somewhat similar to FIND-DFO-AUX, except that it merges
;;; the current component with any strange component, rather than the
(let ((this (block-component block)))
(cond
((not (or (eq this component)
- (eq (component-kind this) :initial)))
+ (eq (component-kind this) :initial)))
(join-components this component)
this)
((block-flag block) component)
(t
(setf (block-flag block) t)
(let ((current (scavenge-home-dependency-graph block component)))
- (dolist (succ (block-succ block))
- (setq current (find-initial-dfo-aux succ current)))
- (remove-from-dfo block)
- (add-to-dfo block (component-head current))
- current)))))
+ (dolist (succ (block-succ block))
+ (setq current (find-initial-dfo-aux succ current)))
+ (remove-from-dfo block)
+ (add-to-dfo block (component-head current))
+ current)))))
;;; Return a list of all the home lambdas that reference FUN (may
;;; contain duplications).
(collect ((res))
(dolist (ref (leaf-refs fun))
(let* ((home (node-home-lambda ref))
- (home-kind (functional-kind home))
- (home-externally-visible-p
- (or (eq home-kind :toplevel)
- (functional-has-external-references-p home))))
- (unless (or (and home-externally-visible-p
- (eq (functional-kind fun) :external))
- (eq home-kind :deleted))
- (res home))))
+ (home-kind (functional-kind home))
+ (home-externally-visible-p
+ (or (eq home-kind :toplevel)
+ (functional-has-external-references-p home)
+ (let ((entry (functional-entry-fun home)))
+ (and entry
+ (functional-has-external-references-p entry))))))
+ (unless (or (and home-externally-visible-p
+ (eq (functional-kind fun) :external))
+ (eq home-kind :deleted))
+ (res home))))
(res)))
;;; If CLAMBDA is already in COMPONENT, just return that
(declare (type clambda clambda) (type component component))
(assert (not (eql (lambda-kind clambda) :deleted)))
(let* ((bind-block (node-block (lambda-bind clambda)))
- (old-lambda-component (block-component bind-block))
- (return (lambda-return clambda)))
+ (old-lambda-component (block-component bind-block))
+ (return (lambda-return clambda)))
(cond
((eq old-lambda-component component)
component)
(t
(push clambda (component-lambdas component))
(setf (component-lambdas old-lambda-component)
- (delete clambda (component-lambdas old-lambda-component)))
+ (delete clambda (component-lambdas old-lambda-component)))
(link-blocks (component-head component) bind-block)
(unlink-blocks (component-head old-lambda-component) bind-block)
(when return
- (let ((return-block (node-block return)))
- (link-blocks return-block (component-tail component))
- (unlink-blocks return-block (component-tail old-lambda-component))))
+ (let ((return-block (node-block return)))
+ (link-blocks return-block (component-tail component))
+ (unlink-blocks return-block (component-tail old-lambda-component))))
(let ((res (find-initial-dfo-aux bind-block component)))
- (declare (type component res))
- ;; Scavenge related lambdas.
- (labels ((scavenge-lambda (clambda)
- (setf res
- (dfo-scavenge-dependency-graph (lambda-home clambda)
- res)))
- (scavenge-possibly-deleted-lambda (clambda)
- (unless (eql (lambda-kind clambda) :deleted)
- (scavenge-lambda clambda)))
- ;; Scavenge call relationship.
- (scavenge-call (called-lambda)
- (scavenge-lambda called-lambda))
- ;; Scavenge closure over a variable: if CLAMBDA
- ;; refers to a variable whose home lambda is not
- ;; CLAMBDA, then the home lambda should be in the
- ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
- ;; CL, didn't do this, leading to the occasional
- ;; failure when physenv analysis, which is local to
- ;; each component, would bogusly conclude that a
- ;; closed-over variable was unused and thus delete
- ;; it. See e.g. cmucl-imp 2001-11-29.)
- (scavenge-closure-var (var)
- (unless (null (lambda-var-refs var)) ; unless var deleted
- (let ((var-home-home (lambda-home (lambda-var-home var))))
- (scavenge-possibly-deleted-lambda var-home-home))))
- ;; Scavenge closure over an entry for nonlocal exit.
- ;; This is basically parallel to closure over a
- ;; variable above.
- (scavenge-entry (entry)
- (declare (type entry entry))
- (let ((entry-home (node-home-lambda entry)))
- (scavenge-possibly-deleted-lambda entry-home))))
- (dolist (cc (lambda-calls-or-closes clambda))
- (etypecase cc
- (clambda (scavenge-call cc))
- (lambda-var (scavenge-closure-var cc))
- (entry (scavenge-entry cc))))
- (when (eq (lambda-kind clambda) :external)
- (mapc #'scavenge-call (find-reference-funs clambda))))
- ;; Voila.
- res)))))
+ (declare (type component res))
+ ;; Scavenge related lambdas.
+ (labels ((scavenge-lambda (clambda)
+ (setf res
+ (dfo-scavenge-dependency-graph (lambda-home clambda)
+ res)))
+ (scavenge-possibly-deleted-lambda (clambda)
+ (unless (eql (lambda-kind clambda) :deleted)
+ (scavenge-lambda clambda)))
+ ;; Scavenge call relationship.
+ (scavenge-call (called-lambda)
+ (scavenge-lambda called-lambda))
+ ;; Scavenge closure over a variable: if CLAMBDA
+ ;; refers to a variable whose home lambda is not
+ ;; CLAMBDA, then the home lambda should be in the
+ ;; same component as CLAMBDA. (sbcl-0.6.13, and CMU
+ ;; CL, didn't do this, leading to the occasional
+ ;; failure when physenv analysis, which is local to
+ ;; each component, would bogusly conclude that a
+ ;; closed-over variable was unused and thus delete
+ ;; it. See e.g. cmucl-imp 2001-11-29.)
+ (scavenge-closure-var (var)
+ (unless (null (lambda-var-refs var)) ; unless var deleted
+ (let ((var-home-home (lambda-home (lambda-var-home var))))
+ (scavenge-possibly-deleted-lambda var-home-home))))
+ ;; Scavenge closure over an entry for nonlocal exit.
+ ;; This is basically parallel to closure over a
+ ;; variable above.
+ (scavenge-entry (entry)
+ (declare (type entry entry))
+ (let ((entry-home (node-home-lambda entry)))
+ (scavenge-possibly-deleted-lambda entry-home))))
+ (do-sset-elements (cc (lambda-calls-or-closes clambda))
+ (etypecase cc
+ (clambda (scavenge-call cc))
+ (lambda-var (scavenge-closure-var cc))
+ (entry (scavenge-entry cc))))
+ (when (eq (lambda-kind clambda) :external)
+ (mapc #'scavenge-call (find-reference-funs clambda))))
+ ;; Voila.
+ res)))))
;;; Return true if CLAMBDA either is an XEP or has EXITS to some of
;;; its ENTRIES.
(declare (type clambda clambda))
(or (eq (functional-kind clambda) :external)
(let ((entries (lambda-entries clambda)))
- (and entries
- (find-if #'entry-exits entries)))))
+ (and entries
+ (find-if #'entry-exits entries)))))
;;; Compute the result of FIND-INITIAL-DFO given the list of all
;;; resulting components. Components with a :TOPLEVEL lambda, but no
(defun separate-toplevelish-components (components)
(declare (list components))
(collect ((real)
- (top)
- (real-top))
+ (top)
+ (real-top))
(dolist (component components)
(unless (eq (block-next (component-head component))
- (component-tail component))
- (let* ((funs (component-lambdas component))
- (has-top (find :toplevel funs :key #'functional-kind))
- (has-external-references
- (some #'functional-has-external-references-p funs)))
- (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
- ;; is newer than the rest of this function, and
- ;; doesn't really seem to fit into its mindset. Here
- ;; we mark components which contain such FUNCTIONs
- ;; them as :COMPLEX-TOPLEVEL, since they do get
- ;; executed at run time, and since it's not valid to
- ;; delete them just because they don't have any
- ;; references from pure :TOPLEVEL components. -- WHN
- has-external-references
- (setf (component-kind component) :complex-toplevel)
- (real component)
- (real-top component))
- ((or (some #'has-xep-or-nlx funs)
- (and has-top (rest funs)))
- (setf (component-name component)
- (find-component-name component))
- (real component)
- (when has-top
- (setf (component-kind component) :complex-toplevel)
- (real-top component)))
- (has-top
- (setf (component-kind component) :toplevel)
- (setf (component-name component) "top level form")
- (top component))
- (t
- (delete-component component))))))
+ (component-tail component))
+ (let* ((funs (component-lambdas component))
+ (has-top (find :toplevel funs :key #'functional-kind))
+ (has-external-references
+ (some #'functional-has-external-references-p funs)))
+ (cond (;; The FUNCTIONAL-HAS-EXTERNAL-REFERENCES-P concept
+ ;; is newer than the rest of this function, and
+ ;; doesn't really seem to fit into its mindset. Here
+ ;; we mark components which contain such FUNCTIONs
+ ;; them as :COMPLEX-TOPLEVEL, since they do get
+ ;; executed at run time, and since it's not valid to
+ ;; delete them just because they don't have any
+ ;; references from pure :TOPLEVEL components. -- WHN
+ has-external-references
+ (setf (component-kind component) :complex-toplevel)
+ (real component)
+ (real-top component))
+ ((or (some #'has-xep-or-nlx funs)
+ (and has-top (rest funs)))
+ (setf (component-name component)
+ (find-component-name component))
+ (real component)
+ (when has-top
+ (setf (component-kind component) :complex-toplevel)
+ (real-top component)))
+ (has-top
+ (setf (component-kind component) :toplevel)
+ (setf (component-name component) "top level form")
+ (top component))
+ (t
+ (delete-component component))))))
(values (real) (top) (real-top))))
-;;; COMPONENTs want strings for names, LEAF-DEBUG-NAMEs mightn't be
-;;; strings...
-(defun component-name-from-functional-debug-name (functional)
- (declare (type functional functional))
- (let ((leaf-debug-name (leaf-debug-name functional)))
- (the simple-string
- (if (stringp leaf-debug-name)
- leaf-debug-name
- (debug-namify "function " leaf-debug-name)))))
-
;;; Given a list of top level lambdas, return
;;; (VALUES NONTOP-COMPONENTS TOP-COMPONENTS HAIRY-TOP-COMPONENTS).
;;; Each of the three values returned is a list of COMPONENTs:
;; are moved to the appropriate new component tail.
(dolist (toplevel-lambda toplevel-lambdas)
(let* ((old-component (lambda-component toplevel-lambda))
- (old-component-lambdas (component-lambdas old-component))
- (new-component nil))
- (aver (member toplevel-lambda old-component-lambdas))
- (dolist (component-lambda old-component-lambdas)
- (aver (member (functional-kind component-lambda)
- '(:optional :external :toplevel nil :escape
- :cleanup)))
- (unless new-component
- (setf new-component (make-empty-component))
- (setf (component-name new-component)
- ;; This isn't necessarily an ideal name for the
- ;; component, since it might end up with multiple
- ;; lambdas in it, not just this one, but it does
- ;; seem a better name than just "<unknown>".
- (component-name-from-functional-debug-name
- component-lambda)))
- (let ((res (dfo-scavenge-dependency-graph component-lambda
- new-component)))
- (when (eq res new-component)
- (aver (not (position new-component (components))))
- (components new-component)
- (setq new-component nil))))
- (when (eq (component-kind old-component) :initial)
- (aver (null (component-lambdas old-component)))
- (let ((tail (component-tail old-component)))
- (dolist (pred (block-pred tail))
- (let ((pred-component (block-component pred)))
- (unless (eq pred-component old-component)
- (unlink-blocks pred tail)
- (link-blocks pred (component-tail pred-component))))))
- (delete-component old-component))))
+ (old-component-lambdas (component-lambdas old-component))
+ (new-component nil))
+ (aver (member toplevel-lambda old-component-lambdas))
+ (dolist (component-lambda old-component-lambdas)
+ (aver (member (functional-kind component-lambda)
+ '(:optional :external :toplevel nil :escape
+ :cleanup)))
+ (unless new-component
+ (setf new-component (make-empty-component))
+ (setf (component-name new-component)
+ ;; This isn't necessarily an ideal name for the
+ ;; component, since it might end up with multiple
+ ;; lambdas in it, not just this one, but it does
+ ;; seem a better name than just "<unknown>".
+ (leaf-debug-name component-lambda)))
+ (let ((res (dfo-scavenge-dependency-graph component-lambda
+ new-component)))
+ (when (eq res new-component)
+ (aver (not (position new-component (components))))
+ (components new-component)
+ (setq new-component nil))))
+ (when (eq (component-kind old-component) :initial)
+ (aver (null (component-lambdas old-component)))
+ (let ((tail (component-tail old-component)))
+ (dolist (pred (block-pred tail))
+ (let ((pred-component (block-component pred)))
+ (unless (eq pred-component old-component)
+ (unlink-blocks pred tail)
+ (link-blocks pred (component-tail pred-component))))))
+ (delete-component old-component))))
;; When we are done, we assign DFNs.
(dolist (component (components))
(let ((num 0))
- (declare (fixnum num))
- (do-blocks-backwards (block component :both)
- (setf (block-number block) (incf num)))))
+ (declare (fixnum num))
+ (do-blocks-backwards (block component :both)
+ (setf (block-number block) (incf num)))))
;; Pull out top-level-ish code.
(separate-toplevelish-components (components))))
(setf (lambda-physenv let) (lambda-physenv result-lambda))
(push let (lambda-lets result-lambda)))
(setf (lambda-entries result-lambda)
- (nconc (lambda-entries result-lambda)
- (lambda-entries lambda)))
+ (nconc (lambda-entries result-lambda)
+ (lambda-entries lambda)))
(let* ((bind (lambda-bind lambda))
- (bind-block (node-block bind))
- (component (block-component bind-block))
- (result-component (lambda-component result-lambda))
- (result-return-block (node-block (lambda-return result-lambda))))
+ (bind-block (node-block bind))
+ (component (block-component bind-block))
+ (result-component (lambda-component result-lambda))
+ (result-return-block (node-block (lambda-return result-lambda))))
;; Move blocks into the new COMPONENT, and move any nodes directly
;; in the old LAMBDA into the new one (with LETs implicitly moved
;; by changing their home.)
(do-blocks (block component)
(do-nodes (node nil block)
- (let ((lexenv (node-lexenv node)))
- (when (eq (lexenv-lambda lexenv) lambda)
- (setf (lexenv-lambda lexenv) result-lambda))))
+ (let ((lexenv (node-lexenv node)))
+ (when (eq (lexenv-lambda lexenv) lambda)
+ (setf (lexenv-lambda lexenv) result-lambda))))
(setf (block-component block) result-component))
;; Splice the blocks into the new DFO, and unlink them from the
;; old component head and tail. Non-return blocks that jump to the
;; tail (NIL-returning calls) are switched to go to the new tail.
(let* ((head (component-head component))
- (first (block-next head))
- (tail (component-tail component))
- (last (block-prev tail))
- (prev (block-prev result-return-block)))
+ (first (block-next head))
+ (tail (component-tail component))
+ (last (block-prev tail))
+ (prev (block-prev result-return-block)))
(setf (block-next prev) first)
(setf (block-prev first) prev)
(setf (block-next last) result-return-block)
(setf (block-prev result-return-block) last)
(dolist (succ (block-succ head))
- (unlink-blocks head succ))
+ (unlink-blocks head succ))
(dolist (pred (block-pred tail))
- (unlink-blocks pred tail)
- (let ((last (block-last pred)))
- (unless (return-p last)
- (aver (basic-combination-p last))
- (link-blocks pred (component-tail result-component))))))
+ (unlink-blocks pred tail)
+ (let ((last (block-last pred)))
+ (unless (return-p last)
+ (aver (basic-combination-p last))
+ (link-blocks pred (component-tail result-component))))))
(let ((lambdas (component-lambdas component)))
(aver (and (null (rest lambdas))
- (eq (first lambdas) lambda))))
+ (eq (first lambdas) lambda))))
;; Switch the end of the code from the return block to the start of
;; the next chunk.
;; is always a preceding REF NIL node in top level lambdas.
(let ((return (lambda-return lambda)))
(when return
- (link-blocks (node-block return) result-return-block)
+ (link-blocks (node-block return) result-return-block)
(flush-dest (return-result return))
(unlink-node return)))))
(defun merge-toplevel-lambdas (lambdas)
(declare (cons lambdas))
(let* ((result-lambda (first lambdas))
- (result-return (lambda-return result-lambda)))
+ (result-return (lambda-return result-lambda)))
(cond
(result-return
;; Make sure the result's return node starts a block so that we
;; can splice code in before it.
(let ((prev (node-prev
- (lvar-uses (return-result result-return)))))
- (when (ctran-use prev)
- (node-ends-block (ctran-use prev))))
+ (lvar-uses (return-result result-return)))))
+ (when (ctran-use prev)
+ (node-ends-block (ctran-use prev))))
(dolist (lambda (rest lambdas))
- (merge-1-toplevel-lambda result-lambda lambda)))
+ (merge-1-toplevel-lambda result-lambda lambda)))
(t
(dolist (lambda (rest lambdas))
- (setf (functional-entry-fun lambda) nil)
- (delete-component (lambda-component lambda)))))
+ (setf (functional-entry-fun lambda) nil)
+ (delete-component (lambda-component lambda)))))
(values (lambda-component result-lambda) result-lambda)))
projects / sbcl.git / blobdiff