X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=9502ae79a06c9340f4007fdedb42dbc11e621d8b;hb=05525d3a5906d7a89fcb689c26177732493c40ce;hp=6c1b5e02fff2f21ed3cffda2567390aef0758cb3;hpb=29a9ccc860532b32c566aec095f570e999a9c52c;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index 6c1b5e0..9502ae7 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -37,17 +37,19 @@ (type (or cleanup null) cleanup)) (setf (component-reanalyze (block-component block1)) t) (with-ir1-environment-from-node node - (let* ((start (make-continuation)) - (block (continuation-starts-block start)) - (cont (make-continuation)) - (*lexenv* (if cleanup - (make-lexenv :cleanup cleanup) - *lexenv*))) - (change-block-successor block1 block2 block) - (link-blocks block block2) - (ir1-convert start cont form) - (setf (block-last block) (continuation-use cont)) - block))) + (with-component-last-block (*current-component* + (block-next (component-head *current-component*))) + (let* ((start (make-continuation)) + (block (continuation-starts-block start)) + (cont (make-continuation)) + (*lexenv* (if cleanup + (make-lexenv :cleanup cleanup) + *lexenv*))) + (change-block-successor block1 block2 block) + (link-blocks block block2) + (ir1-convert start cont form) + (setf (block-last block) (continuation-use cont)) + block)))) ;;;; continuation use hacking @@ -61,6 +63,12 @@ (:unused nil) (:deleted nil))) +(defun principal-continuation-use (cont) + (let ((use (continuation-use cont))) + (if (cast-p use) + (principal-continuation-use (cast-value use)) + use))) + ;;; Update continuation use information so that NODE is no longer a ;;; use of its CONT. If the old continuation doesn't start its block, ;;; then we don't update the BLOCK-START-USES, since it will be @@ -112,7 +120,10 @@ (let ((uses (cons node (block-start-uses block)))) (setf (block-start-uses block) uses) (setf (continuation-use cont) - (if (cdr uses) nil (car uses))))))) + (if (cdr uses) nil (car uses))) + (let ((block (node-block node))) + (unless (block-last block) + (setf (block-last block) node))))))) (setf (node-cont node) cont) (values)) @@ -122,6 +133,8 @@ (declare (type continuation cont) (type node node)) (and (eq (node-cont node) cont) (not (eq (continuation-kind cont) :deleted)) + (eq (continuation-dest cont) + (continuation-next cont)) (let ((cblock (continuation-block cont)) (nblock (node-block node))) (or (eq cblock nblock) @@ -148,10 +161,13 @@ (if (eq old (basic-combination-fun dest)) (setf (basic-combination-fun dest) new) (setf (basic-combination-args dest) - (nsubst new old (basic-combination-args dest)))))) + (nsubst new old (basic-combination-args dest))))) + (cast (setf (cast-value dest) new)) + (null)) - (flush-dest old) - (setf (continuation-dest new) dest)) + (when dest (flush-dest old)) + (setf (continuation-dest new) dest) + (flush-continuation-externally-checkable-type new)) (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an @@ -167,7 +183,7 @@ (do-uses (node old) (delete-continuation-use node) (add-continuation-use node new)) - (dolist (lexenv-use (continuation-lexenv-uses old)) + (dolist (lexenv-use (continuation-lexenv-uses old)) ; FIXME - APD (setf (cadr lexenv-use) new)) (reoptimize-continuation new) @@ -189,16 +205,16 @@ (ecase (continuation-kind cont) (:unused (aver (not (continuation-block cont))) - (let* ((head (component-head *current-component*)) - (next (block-next head)) - (new-block (make-block cont))) - (setf (block-next new-block) next) - (setf (block-prev new-block) head) - (setf (block-prev next) new-block) - (setf (block-next head) new-block) - (setf (continuation-block cont) new-block) - (setf (continuation-use cont) nil) - (setf (continuation-kind cont) :block-start) + (let* ((next (component-last-block *current-component*)) + (prev (block-prev next)) + (new-block (make-block cont))) + (setf (block-next new-block) next + (block-prev new-block) prev + (block-prev next) new-block + (block-next prev) new-block + (continuation-block cont) new-block + (continuation-use cont) nil + (continuation-kind cont) :block-start) new-block)) (:block-start (continuation-block cont)))) @@ -209,7 +225,7 @@ ;;; CONT of LAST in its block, then we make it the start of a new ;;; deleted block. ;;; -- If the continuation is :INSIDE-BLOCK inside a block, then we -;;; split the block using Node-Ends-Block, which makes the +;;; split the block using NODE-ENDS-BLOCK, which makes the ;;; continuation be a :BLOCK-START. (defun ensure-block-start (cont) (declare (type continuation cont)) @@ -229,6 +245,112 @@ (node-ends-block (continuation-use cont)))))))) (values)) +;;;; + +;;; Filter values of CONT with a destination through FORM, which must +;;; be an ordinary/mv call. First argument must be 'DUMMY, which will +;;; be replaced with CONT. In case of an ordinary call the function +;;; should not have return type NIL. +;;; +;;; TODO: remove preconditions. +(defun filter-continuation (cont form) + (declare (type continuation cont) (type list form)) + (let ((dest (continuation-dest cont))) + (declare (type node dest)) + (with-ir1-environment-from-node dest + + ;; Ensuring that CONT starts a block lets us freely manipulate its uses. + (ensure-block-start cont) + + ;; Make a new continuation and move CONT's uses to it. + (let ((new-start (make-continuation)) + (prev (node-prev dest))) + (continuation-starts-block new-start) + (substitute-continuation-uses new-start cont) + + ;; Make the DEST node start its block so that we can splice in + ;; the LAMBDA code. + (when (continuation-use prev) + (node-ends-block (continuation-use prev))) + + (let* ((prev-block (continuation-block prev)) + (new-block (continuation-block new-start)) + (dummy (make-continuation))) + + ;; Splice in the new block before DEST, giving the new block + ;; all of DEST's predecessors. + (dolist (block (block-pred prev-block)) + (change-block-successor block prev-block new-block)) + + ;; Convert the lambda form, using the new block start as + ;; START and a dummy continuation as CONT. + (ir1-convert new-start dummy form) + + ;; TODO: Why should this be true? -- WHN 19990601 + ;; + ;; It is somehow related to the precondition of non-NIL + ;; return type of the function. -- APD 2003-3-24 + (aver (eq (continuation-block dummy) new-block)) + + ;; KLUDGE: Comments at the head of this function in CMU CL + ;; said that somewhere in here we + ;; Set the new block's start and end cleanups to the *start* + ;; cleanup of PREV's block. This overrides the incorrect + ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE. + ;; Unfortunately I can't find any code which corresponds to this. + ;; Perhaps it was a stale comment? Or perhaps I just don't + ;; understand.. -- WHN 19990521 + + (let ((node (continuation-use dummy))) + (setf (block-last new-block) node) + ;; Change the use to a use of CONT. (We need to use the + ;; dummy continuation to get the control transfer right, + ;; because we want to go to PREV's block, not CONT's.) + (delete-continuation-use node) + (add-continuation-use node cont)) + ;; Link the new block to PREV's block. + (link-blocks new-block prev-block)) + + ;; Replace 'DUMMY with the new continuation. (We can find + ;; 'DUMMY because no LET conversion has been done yet.) The + ;; [mv-]combination code from the call in the form will be the + ;; use of the new check continuation. We substitute for the + ;; first argument of this node. + (let* ((node (continuation-use cont)) + (args (basic-combination-args node)) + (victim (first args))) + (aver (eq (constant-value (ref-leaf (continuation-use victim))) + 'dummy)) + (substitute-continuation new-start victim))) + + ;; Invoking local call analysis converts this call to a LET. + (locall-analyze-component *current-component*) + + (values)))) + +;;; Deleting a filter may result in some calls becoming tail. +(defun delete-filter (node cont value) + (collect ((merges)) + (prog2 + (when (return-p (continuation-dest cont)) + (do-uses (use value) + (when (and (basic-combination-p use) + (eq (basic-combination-kind use) :local)) + (merges use)))) + (cond ((and (eq (continuation-kind cont) :inside-block) + (eq (continuation-kind value) :inside-block)) + (setf (continuation-dest value) nil) + (substitute-continuation value cont) + (prog1 (unlink-node node) + (setq cont value))) + (t (ensure-block-start value) + (ensure-block-start cont) + (substitute-continuation-uses cont value) + (prog1 (unlink-node node) + (setf (continuation-dest value) nil)))) + (dolist (merge (merges)) + (merge-tail-sets merge))))) + ;;;; miscellaneous shorthand functions ;;; Return the home (i.e. enclosing non-LET) CLAMBDA for NODE. Since @@ -277,8 +399,8 @@ ;;; (BLOCK B (RETURN-FROM B) (SETQ X 3)) ;;; where the block is just a placeholder during parsing and doesn't ;;; actually correspond to code which will be written anywhere. +(declaim (ftype (sfunction (cblock) (or clambda null)) block-home-lambda-or-null)) (defun block-home-lambda-or-null (block) - (declare (type cblock block)) (if (node-p (block-last block)) ;; This is the old CMU CL way of doing it. (node-home-lambda (block-last block)) @@ -360,6 +482,8 @@ (values nil nil)))) ;;; Return the LAMBDA that is CONT's home, or NIL if there is none. +(declaim (ftype (sfunction (continuation) (or clambda null)) + continuation-home-lambda-or-null)) (defun continuation-home-lambda-or-null (cont) ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this ;; implementation might not be quite right, or might be uglier than @@ -375,19 +499,36 @@ ((continuation-block cont) (block-home-lambda-or-null (continuation-block cont))) (t - (error "internal error: confused about home lambda for ~S")))) + (bug "confused about home lambda for ~S")))) ;;; Return the LAMBDA that is CONT's home. (defun continuation-home-lambda (cont) (the clambda (continuation-home-lambda-or-null cont))) + +#!-sb-fluid (declaim (inline continuation-single-value-p)) +(defun continuation-single-value-p (cont) + (let ((dest (continuation-dest cont))) + (typecase dest + ((or creturn exit cast) + nil) + (mv-combination + (eq (basic-combination-fun dest) cont)) + (t + t)))) + +(defun principal-continuation-end (cont) + (loop for prev = cont then (node-cont dest) + for dest = (continuation-dest prev) + while (cast-p dest) + finally (return (values dest prev)))) ;;; Return a new LEXENV just like DEFAULT except for the specified ;;; slot values. Values for the alist slots are NCONCed to the ;;; beginning of the current value, rather than replacing it entirely. (defun make-lexenv (&key (default *lexenv*) - functions variables blocks tags type-restrictions - options + funs vars blocks tags + type-restrictions weakend-type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) (policy (lexenv-policy default))) @@ -397,13 +538,43 @@ (nconc ,var old) old)))) (internal-make-lexenv - (frob functions lexenv-functions) - (frob variables lexenv-variables) + (frob funs lexenv-funs) + (frob vars lexenv-vars) (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy - (frob options lexenv-options)))) + (frob weakend-type-restrictions lexenv-weakend-type-restrictions) + lambda cleanup policy))) + +;;; Makes a LEXENV, suitable for using in a MACROLET introduced +;;; macroexpander +(defun make-restricted-lexenv (lexenv) + (flet ((fun-good-p (fun) + (destructuring-bind (name . thing) fun + (declare (ignore name)) + (etypecase thing + (functional nil) + (global-var t) + (cons (aver (eq (car thing) 'macro)) + t)))) + (var-good-p (var) + (destructuring-bind (name . thing) var + (declare (ignore name)) + (etypecase thing + (leaf nil) + (cons (aver (eq (car thing) 'macro)) + t) + (heap-alien-info nil))))) + (internal-make-lexenv + (remove-if-not #'fun-good-p (lexenv-funs lexenv)) + (remove-if-not #'var-good-p (lexenv-vars lexenv)) + nil + nil + (lexenv-type-restrictions lexenv) ; XXX + (lexenv-weakend-type-restrictions lexenv) + nil + nil + (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -439,7 +610,7 @@ (let ((new-pred (delq block1 (block-pred block2)))) (setf (block-pred block2) new-pred) - (when (and new-pred (null (rest new-pred))) + (when (singleton-p new-pred) (let ((pred-block (first new-pred))) (when (if-p (block-last pred-block)) (setf (block-test-modified pred-block) t))))) @@ -470,7 +641,10 @@ `(when (eq (,slot last) old) (setf (,slot last) new)))) (frob if-consequent) - (frob if-alternative)))) + (frob if-alternative) + (when (eq (if-consequent last) + (if-alternative last)) + (setf (component-reoptimize (block-component block)) t))))) (t (unless (member new (block-succ block) :test #'eq) (link-blocks block new))))) @@ -489,7 +663,7 @@ (values)) ;;; Add BLOCK to the next/prev chain following AFTER. We also set the -;;; Component to be the same as for AFTER. +;;; COMPONENT to be the same as for AFTER. (defun add-to-dfo (block after) (declare (type cblock block after)) (let ((next (block-next after)) @@ -520,7 +694,7 @@ (defun make-empty-component () (let* ((head (make-block-key :start nil :component nil)) (tail (make-block-key :start nil :component nil)) - (res (make-component :head head :tail tail))) + (res (make-component head tail))) (setf (block-flag head) t) (setf (block-flag tail) t) (setf (block-component head) res) @@ -555,7 +729,7 @@ (link-blocks block new-block) (add-to-dfo new-block block) (setf (component-reanalyze (block-component block)) t) - + (do ((cont start (node-cont (continuation-next cont)))) ((eq cont last-cont) (when (eq (continuation-kind last-cont) :inside-block) @@ -569,18 +743,14 @@ ;;;; deleting stuff -;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. We -;;; iterate over all local calls flushing the corresponding argument, -;;; allowing the computation of the argument to be deleted. We also -;;; mark the let for reoptimization, since it may be that we have -;;; deleted the last variable. -;;; -;;; The LAMBDA-VAR may still have some SETs, but this doesn't cause -;;; too much difficulty, since we can efficiently implement write-only -;;; variables. We iterate over the sets, marking their blocks for dead -;;; code flushing, since we can delete sets whose value is unused. +;;; Deal with deleting the last (read) reference to a LAMBDA-VAR. (defun delete-lambda-var (leaf) (declare (type lambda-var leaf)) + + ;; Iterate over all local calls flushing the corresponding argument, + ;; allowing the computation of the argument to be deleted. We also + ;; mark the LET for reoptimization, since it may be that we have + ;; deleted its last variable. (let* ((fun (lambda-var-home leaf)) (n (position leaf (lambda-vars fun)))) (dolist (ref (leaf-refs fun)) @@ -595,17 +765,22 @@ (flush-dest arg) (setf (elt args n) nil)))))) + ;; The LAMBDA-VAR may still have some SETs, but this doesn't cause + ;; too much difficulty, since we can efficiently implement + ;; write-only variables. We iterate over the SETs, marking their + ;; blocks for dead code flushing, since we can delete SETs whose + ;; value is unused. (dolist (set (lambda-var-sets leaf)) (setf (block-flush-p (node-block set)) t)) (values)) -;;; Note that something interesting has happened to VAR. We only deal -;;; with LET variables, marking the corresponding initial value arg as -;;; needing to be reoptimized. +;;; Note that something interesting has happened to VAR. (defun reoptimize-lambda-var (var) (declare (type lambda-var var)) (let ((fun (lambda-var-home var))) + ;; We only deal with LET variables, marking the corresponding + ;; initial value arg as needing to be reoptimized. (when (and (eq (functional-kind fun) :let) (leaf-refs var)) (do ((args (basic-combination-args @@ -629,58 +804,68 @@ (clambda (delete-lambda fun))) (values)) -;;; Deal with deleting the last reference to a LAMBDA. Since there is -;;; only one way into a LAMBDA, deleting the last reference to a -;;; LAMBDA ensures that there is no way to reach any of the code in +;;; Deal with deleting the last reference to a CLAMBDA. Since there is +;;; only one way into a CLAMBDA, deleting the last reference to a +;;; CLAMBDA ensures that there is no way to reach any of the code in ;;; it. So we just set the FUNCTIONAL-KIND for FUN and its LETs to ;;; :DELETED, causing IR1 optimization to delete blocks in that -;;; lambda. -;;; -;;; If the function isn't a LET, we unlink the function head and tail -;;; from the component head and tail to indicate that the code is -;;; unreachable. We also delete the function from COMPONENT-LAMBDAS -;;; (it won't be there before local call analysis, but no matter.) If -;;; the lambda was never referenced, we give a note. -;;; -;;; If the lambda is an XEP, then we null out the ENTRY-FUN in its -;;; ENTRY-FUN so that people will know that it is not an entry point -;;; anymore. -(defun delete-lambda (leaf) - (declare (type clambda leaf)) - (let ((kind (functional-kind leaf)) - (bind (lambda-bind leaf))) - (aver (not (member kind '(:deleted :optional :toplevel)))) - (aver (not (functional-has-external-references-p leaf))) - (setf (functional-kind leaf) :deleted) - (setf (lambda-bind leaf) nil) - (dolist (let (lambda-lets leaf)) +;;; CLAMBDA. +(defun delete-lambda (clambda) + (declare (type clambda clambda)) + (let ((original-kind (functional-kind clambda)) + (bind (lambda-bind clambda))) + (aver (not (member original-kind '(:deleted :optional :toplevel)))) + (aver (not (functional-has-external-references-p clambda))) + (setf (functional-kind clambda) :deleted) + (setf (lambda-bind clambda) nil) + (dolist (let (lambda-lets clambda)) (setf (lambda-bind let) nil) (setf (functional-kind let) :deleted)) - (if (member kind '(:let :mv-let :assignment)) - (let ((home (lambda-home leaf))) - (setf (lambda-lets home) (delete leaf (lambda-lets home)))) + ;; LET may be deleted if its BIND is unreachable. Autonomous + ;; function may be deleted if it has no reachable references. + (unless (member original-kind '(:let :mv-let :assignment)) + (dolist (ref (lambda-refs clambda)) + (mark-for-deletion (node-block ref)))) + + ;; (The IF test is (FUNCTIONAL-SOMEWHAT-LETLIKE-P CLAMBDA), except + ;; that we're using the old value of the KIND slot, not the + ;; current slot value, which has now been set to :DELETED.) + (if (member original-kind '(:let :mv-let :assignment)) + (let ((home (lambda-home clambda))) + (setf (lambda-lets home) (delete clambda (lambda-lets home)))) + ;; If the function isn't a LET, we unlink the function head + ;; and tail from the component head and tail to indicate that + ;; the code is unreachable. We also delete the function from + ;; COMPONENT-LAMBDAS (it won't be there before local call + ;; analysis, but no matter.) If the lambda was never + ;; referenced, we give a note. (let* ((bind-block (node-block bind)) (component (block-component bind-block)) - (return (lambda-return leaf))) - (aver (null (leaf-refs leaf))) - (unless (leaf-ever-used leaf) + (return (lambda-return clambda)) + (return-block (and return (node-block return)))) + (unless (leaf-ever-used clambda) (let ((*compiler-error-context* bind)) (compiler-note "deleting unused function~:[.~;~:*~% ~S~]" - (leaf-debug-name leaf)))) - (unlink-blocks (component-head component) bind-block) - (when return - (unlink-blocks (node-block return) (component-tail component))) + (leaf-debug-name clambda)))) + (unless (block-delete-p bind-block) + (unlink-blocks (component-head component) bind-block)) + (when (and return-block (not (block-delete-p return-block))) + (mark-for-deletion return-block) + (unlink-blocks return-block (component-tail component))) (setf (component-reanalyze component) t) - (let ((tails (lambda-tail-set leaf))) + (let ((tails (lambda-tail-set clambda))) (setf (tail-set-funs tails) - (delete leaf (tail-set-funs tails))) - (setf (lambda-tail-set leaf) nil)) + (delete clambda (tail-set-funs tails))) + (setf (lambda-tail-set clambda) nil)) (setf (component-lambdas component) - (delete leaf (component-lambdas component))))) + (delete clambda (component-lambdas component))))) - (when (eq kind :external) - (let ((fun (functional-entry-fun leaf))) + ;; If the lambda is an XEP, then we null out the ENTRY-FUN in its + ;; ENTRY-FUN so that people will know that it is not an entry + ;; point anymore. + (when (eq original-kind :external) + (let ((fun (functional-entry-fun clambda))) (setf (functional-entry-fun fun) nil) (when (optional-dispatch-p fun) (delete-optional-dispatch fun))))) @@ -700,11 +885,11 @@ ;;; entry-points, making them be normal lambdas, and then deleting the ;;; ones with no references. This deletes any e-p lambdas that were ;;; either never referenced, or couldn't be deleted when the last -;;; deference was deleted (due to their :OPTIONAL kind.) +;;; reference was deleted (due to their :OPTIONAL kind.) ;;; -;;; Note that the last optional ep may alias the main entry, so when -;;; we process the main entry, its kind may have been changed to NIL -;;; or even converted to a let. +;;; Note that the last optional entry point may alias the main entry, +;;; so when we process the main entry, its KIND may have been changed +;;; to NIL or even converted to a LETlike value. (defun delete-optional-dispatch (leaf) (declare (type optional-dispatch leaf)) (let ((entry (functional-entry-fun leaf))) @@ -724,7 +909,7 @@ (maybe-convert-to-assignment fun))) (t (maybe-convert-to-assignment fun))))))) - + (dolist (ep (optional-dispatch-entry-points leaf)) (frob ep)) (when (optional-dispatch-more-entry leaf) @@ -751,7 +936,7 @@ (clambda (ecase (functional-kind leaf) ((nil :let :mv-let :assignment :escape :cleanup) - (aver (not (functional-entry-fun leaf))) + (aver (null (functional-entry-fun leaf))) (delete-lambda leaf)) (:external (delete-lambda leaf)) @@ -776,7 +961,7 @@ ;;; containing uses of CONT and set COMPONENT-REOPTIMIZE. If the PREV ;;; of the use is deleted, then we blow off reoptimization. ;;; -;;; If the continuation is :Deleted, then we don't do anything, since +;;; If the continuation is :DELETED, then we don't do anything, since ;;; all semantics have already been flushed. :DELETED-BLOCK-START ;;; start continuations are treated just like :BLOCK-START; it is ;;; possible that the continuation may be given a new dest (e.g. by @@ -787,6 +972,7 @@ (unless (eq (continuation-kind cont) :deleted) (aver (continuation-dest cont)) (setf (continuation-dest cont) nil) + (flush-continuation-externally-checkable-type cont) (do-uses (use cont) (let ((prev (node-prev use))) (unless (eq (continuation-kind prev) :deleted) @@ -795,19 +981,33 @@ (setf (block-attributep (block-flags block) flush-p type-asserted) t)))))) - (setf (continuation-%type-check cont) nil) - (values)) +(defun delete-dest (cont) + (let ((dest (continuation-dest cont))) + (when dest + (let ((prev (node-prev dest))) + (when (and prev + (not (eq (continuation-kind prev) :deleted))) + (let ((block (continuation-block prev))) + (unless (block-delete-p block) + (mark-for-deletion block)))))))) + ;;; Do a graph walk backward from BLOCK, marking all predecessor ;;; blocks with the DELETE-P flag. (defun mark-for-deletion (block) (declare (type cblock block)) - (unless (block-delete-p block) - (setf (block-delete-p block) t) - (setf (component-reanalyze (block-component block)) t) - (dolist (pred (block-pred block)) - (mark-for-deletion pred))) + (let* ((component (block-component block)) + (head (component-head component))) + (labels ((helper (block) + (setf (block-delete-p block) t) + (dolist (pred (block-pred block)) + (unless (or (block-delete-p pred) + (eq pred head)) + (helper pred))))) + (unless (block-delete-p block) + (helper block) + (setf (component-reanalyze component) t)))) (values)) ;;; Delete CONT, eliminating both control and value semantics. We set @@ -831,24 +1031,16 @@ (setf (block-attributep (block-flags block) flush-p type-asserted) t) (setf (component-reoptimize (block-component block)) t))))) - (let ((dest (continuation-dest cont))) - (when dest - (let ((prev (node-prev dest))) - (when (and prev - (not (eq (continuation-kind prev) :deleted))) - (let ((block (continuation-block prev))) - (unless (block-delete-p block) - (mark-for-deletion block))))))) + (delete-dest cont) (setf (continuation-kind cont) :deleted) (setf (continuation-dest cont) nil) + (flush-continuation-externally-checkable-type cont) (setf (continuation-next cont) nil) - (setf (continuation-asserted-type cont) *empty-type*) (setf (continuation-%derived-type cont) *empty-type*) (setf (continuation-use cont) nil) (setf (continuation-block cont) nil) (setf (continuation-reoptimize cont) nil) - (setf (continuation-%type-check cont) nil) (setf (continuation-info cont) nil) (values)) @@ -863,7 +1055,7 @@ ;;; whose values are received by nodes in the block. (defun delete-block (block) (declare (type cblock block)) - (aver (block-component block)) ; else block is already deleted! + (aver (block-component block)) ; else block is already deleted! (note-block-deletion block) (setf (block-delete-p block) t) @@ -875,7 +1067,14 @@ (reoptimize-continuation cont))) (dolist (b (block-pred block)) - (unlink-blocks b block)) + (unlink-blocks b block) + ;; In bug 147 the almost-all-blocks-have-a-successor invariant was + ;; broken when successors were deleted without setting the + ;; BLOCK-DELETE-P flags of their predececessors. Make sure that + ;; doesn't happen again. + (aver (not (and (null (block-succ b)) + (not (block-delete-p b)) + (not (eq b (component-head (block-component b)))))))) (dolist (b (block-succ block)) (unlink-blocks block b)) @@ -893,9 +1092,10 @@ ;; Guards COMBINATION-LAMBDA agains the REF being deleted. (continuation-use (basic-combination-fun node))) (let ((fun (combination-lambda node))) - ;; If our REF was the 2'nd to last ref, and has been deleted, then - ;; Fun may be a LET for some other combination. - (when (and (member (functional-kind fun) '(:let :mv-let)) + ;; If our REF was the second-to-last ref, and has been + ;; deleted, then FUN may be a LET for some other + ;; combination. + (when (and (functional-letlike-p fun) (eq (let-combination fun) node)) (delete-lambda fun)))) (flush-dest (basic-combination-fun node)) @@ -904,7 +1104,6 @@ (bind (let ((lambda (bind-lambda node))) (unless (eq (functional-kind lambda) :deleted) - (aver (member (functional-kind lambda) '(:let :mv-let :assignment))) (delete-lambda lambda)))) (exit (let ((value (exit-value node)) @@ -921,20 +1120,25 @@ (flush-dest (set-value node)) (let ((var (set-var node))) (setf (basic-var-sets var) - (delete node (basic-var-sets var)))))) + (delete node (basic-var-sets var))))) + (cast + (flush-dest (cast-value node)))) (delete-continuation (node-prev node))) (remove-from-dfo block) (values)) -;;; Do stuff to indicate that the return node Node is being deleted. -;;; We set the RETURN to NIL. +;;; Do stuff to indicate that the return node NODE is being deleted. (defun delete-return (node) (declare (type creturn node)) - (let ((fun (return-lambda node))) + (let* ((fun (return-lambda node)) + (tail-set (lambda-tail-set fun))) (aver (lambda-return fun)) - (setf (lambda-return fun) nil)) + (setf (lambda-return fun) nil) + (when (and tail-set (not (find-if #'lambda-return + (tail-set-funs tail-set)))) + (setf (tail-set-type tail-set) *empty-type*))) (values)) ;;; If any of the VARS in FUN was never referenced and was not @@ -1064,7 +1268,10 @@ (setf (continuation-next prev) nil)) (t (setf (continuation-next prev) next) - (setf (node-prev next) prev))) + (setf (node-prev next) prev) + (when (and (if-p next) ; AOP wanted + (eq prev (if-test next))) + (reoptimize-continuation prev)))) (setf (node-prev node) nil) nil) (t @@ -1072,7 +1279,7 @@ (aver (eq node last)) (let* ((succ (block-succ block)) (next (first succ))) - (aver (and succ (null (cdr succ)))) + (aver (singleton-p succ)) (cond ((member block succ) (with-ir1-environment-from-node node @@ -1115,7 +1322,7 @@ ;;; triggered by deletion. (defun delete-component (component) (declare (type component component)) - (aver (null (component-new-funs component))) + (aver (null (component-new-functionals component))) (setf (component-kind component) :deleted) (do-blocks (block component) (setf (block-delete-p block) t)) @@ -1162,17 +1369,27 @@ (before-args (subseq outside-args 0 arg-position)) (after-args (subseq outside-args (1+ arg-position)))) (dolist (arg inside-args) - (setf (continuation-dest arg) outside)) + (setf (continuation-dest arg) outside) + (flush-continuation-externally-checkable-type arg)) (setf (combination-args inside) nil) (setf (combination-args outside) (append before-args inside-args after-args)) (change-ref-leaf (continuation-use inside-fun) (find-free-fun 'list "???")) - (setf (combination-kind inside) :full) + (setf (combination-kind inside) + (info :function :info 'list)) (setf (node-derived-type inside) *wild-type*) (flush-dest cont) - (setf (continuation-asserted-type cont) *wild-type*) (values)))))) + +(defun flush-combination (combination) + (declare (type combination combination)) + (flush-dest (combination-fun combination)) + (dolist (arg (combination-args combination)) + (flush-dest arg)) + (unlink-node combination) + (values)) + ;;;; leaf hackery @@ -1183,10 +1400,16 @@ (push ref (leaf-refs leaf)) (delete-ref ref) (setf (ref-leaf ref) leaf) - (let ((ltype (leaf-type leaf))) - (if (fun-type-p ltype) - (setf (node-derived-type ref) ltype) - (derive-node-type ref ltype))) + (setf (leaf-ever-used leaf) t) + (let* ((ltype (leaf-type leaf)) + (vltype (make-single-value-type ltype))) + (if (let* ((cont (node-cont ref)) + (dest (continuation-dest cont))) + (and (basic-combination-p dest) + (eq cont (basic-combination-fun dest)) + (csubtypep ltype (specifier-type 'function)))) + (setf (node-derived-type ref) vltype) + (derive-node-type ref vltype))) (reoptimize-continuation (node-cont ref))) (values)) @@ -1197,8 +1420,8 @@ (change-ref-leaf ref new-leaf)) (values)) -;;; Like SUBSITUTE-LEAF, only there is a predicate on the REF to tell -;;; whether to substitute. +;;; like SUBSITUTE-LEAF, only there is a predicate on the REF to tell +;;; whether to substitute (defun substitute-leaf-if (test new-leaf old-leaf) (declare (type leaf new-leaf old-leaf) (type function test)) (dolist (ref (leaf-refs old-leaf)) @@ -1225,6 +1448,21 @@ :type (ctype-of object) :where-from :defined))) +;;; Return true if VAR would have to be closed over if environment +;;; analysis ran now (i.e. if there are any uses that have a different +;;; home lambda than VAR's home.) +(defun closure-var-p (var) + (declare (type lambda-var var)) + (let ((home (lambda-var-home var))) + (cond ((eq (functional-kind home) :deleted) + nil) + (t (let ((home (lambda-home home))) + (flet ((frob (l) + (find home l :key #'node-home-lambda + :test-not #'eq))) + (or (frob (leaf-refs var)) + (frob (basic-var-sets var))))))))) + ;;; If there is a non-local exit noted in ENTRY's environment that ;;; exits to CONT in that entry, then return it, otherwise return NIL. (defun find-nlx-info (entry cont) @@ -1288,10 +1526,16 @@ nil)) nil))) +;;; Return the source name of a combination. (This is an idiom +;;; which was used in CMU CL. I gather it always works. -- WHN) +(defun combination-fun-source-name (combination) + (let ((ref (continuation-use (combination-fun combination)))) + (leaf-source-name (ref-leaf ref)))) + ;;; Return the COMBINATION node that is the call to the LET FUN. (defun let-combination (fun) (declare (type clambda fun)) - (aver (member (functional-kind fun) '(:let :mv-let))) + (aver (functional-letlike-p fun)) (continuation-dest (node-cont (first (leaf-refs fun))))) ;;; Return the initial value continuation for a LET variable, or NIL @@ -1344,22 +1588,45 @@ ;;; Apply a function to some arguments, returning a list of the values ;;; resulting of the evaluation. If an error is signalled during the -;;; application, then we print a warning message and return NIL as our -;;; second value to indicate this. Node is used as the error context -;;; for any error message, and Context is a string that is spliced -;;; into the warning. -(declaim (ftype (function ((or symbol function) list node string) +;;; application, then we produce a warning message using WARN-FUN and +;;; return NIL as our second value to indicate this. NODE is used as +;;; the error context for any error message, and CONTEXT is a string +;;; that is spliced into the warning. +(declaim (ftype (function ((or symbol function) list node function string) (values list boolean)) careful-call)) -(defun careful-call (function args node context) +(defun careful-call (function args node warn-fun context) (values (multiple-value-list (handler-case (apply function args) (error (condition) (let ((*compiler-error-context* node)) - (compiler-warn "Lisp error during ~A:~%~A" context condition) + (funcall warn-fun "Lisp error during ~A:~%~A" context condition) (return-from careful-call (values nil nil)))))) t)) + +;;; Variations of SPECIFIER-TYPE for parsing possibly wrong +;;; specifiers. +(macrolet + ((deffrob (basic careful compiler transform) + `(progn + (defun ,careful (specifier) + (handler-case (,basic specifier) + (simple-error (condition) + (values nil (list* (simple-condition-format-control condition) + (simple-condition-format-arguments condition)))))) + (defun ,compiler (specifier) + (multiple-value-bind (type error-args) (,careful specifier) + (or type + (apply #'compiler-error error-args)))) + (defun ,transform (specifier) + (multiple-value-bind (type error-args) (,careful specifier) + (or type + (apply #'give-up-ir1-transform + error-args))))))) + (deffrob specifier-type careful-specifier-type compiler-specifier-type ir1-transform-specifier-type) + (deffrob values-specifier-type careful-values-specifier-type compiler-values-specifier-type ir1-transform-values-specifier-type)) + ;;;; utilities used at run-time for parsing &KEY args in IR1 @@ -1413,3 +1680,33 @@ (let ((action (event-info-action info))) (when action (funcall action node)))) + +;;; +(defun make-cast (value type policy) + (declare (type continuation value) + (type ctype type) + (type policy policy)) + (%make-cast :asserted-type type + :type-to-check (maybe-weaken-check type policy) + :value value + :derived-type (coerce-to-values type))) + +(defun cast-type-check (cast) + (declare (type cast cast)) + (when (cast-reoptimize cast) + (ir1-optimize-cast cast t)) + (cast-%type-check cast)) + +(defun note-single-valuified-continuation (cont) + (declare (type continuation cont)) + (let ((use (continuation-use cont))) + (cond ((ref-p use) + (let ((leaf (ref-leaf use))) + (when (and (lambda-var-p leaf) + (null (rest (leaf-refs leaf)))) + (reoptimize-lambda-var leaf)))) + ((or (null use) (combination-p use)) + (dolist (node (find-uses cont)) + (setf (node-reoptimize node) t) + (setf (block-reoptimize (node-block node)) t) + (setf (component-reoptimize (node-component node)) t))))))