X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=23281cb22ae2a1d2955bb147d84db46db7a57a0c;hb=0794cd3908a441222f430ba0cf3bb7c3e1a96c63;hp=b43723721fe1af347a741f771121ac0acc1c9ef4;hpb=82653abf5573c22c691e2243b70647ecdaa6aea8;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index b437237..23281cb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -37,107 +37,114 @@ (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-ctran)) + (block (ctran-starts-block start)) + (next (make-ctran)) + (*lexenv* (if cleanup + (make-lexenv :cleanup cleanup) + *lexenv*))) + (change-block-successor block1 block2 block) + (link-blocks block block2) + (ir1-convert start next nil form) + (setf (block-last block) (ctran-use next)) + (setf (node-next (block-last block)) nil) + block)))) -;;;; continuation use hacking - -;;; Return a list of all the nodes which use Cont. -(declaim (ftype (function (continuation) list) find-uses)) -(defun find-uses (cont) - (ecase (continuation-kind cont) - ((:block-start :deleted-block-start) - (block-start-uses (continuation-block cont))) - (:inside-block (list (continuation-use cont))) - (:unused nil) - (:deleted nil))) - -;;; 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 -;;; deleted when we are done. +;;;; lvar use hacking + +;;; Return a list of all the nodes which use LVAR. +(declaim (ftype (sfunction (lvar) list) find-uses)) +(defun find-uses (lvar) + (let ((uses (lvar-uses lvar))) + (if (listp uses) + uses + (list uses)))) + +(defun principal-lvar-use (lvar) + (let ((use (lvar-uses lvar))) + (if (cast-p use) + (principal-lvar-use (cast-value use)) + use))) + +;;; Update lvar use information so that NODE is no longer a use of its +;;; LVAR. ;;; ;;; Note: if you call this function, you may have to do a -;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something -;;; has changed. -(declaim (ftype (function (node) (values)) delete-continuation-use)) -(defun delete-continuation-use (node) - (let* ((cont (node-cont node)) - (block (continuation-block cont))) - (ecase (continuation-kind cont) - (:deleted) - ((:block-start :deleted-block-start) - (let ((uses (delete node (block-start-uses block)))) - (setf (block-start-uses block) uses) - (setf (continuation-use cont) - (if (cdr uses) nil (car uses))))) - (:inside-block - (setf (continuation-kind cont) :unused) - (setf (continuation-block cont) nil) - (setf (continuation-use cont) nil) - (setf (continuation-next cont) nil))) - (setf (node-cont node) nil)) +;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has +;;; changed. +(declaim (ftype (sfunction (node) (values)) + delete-lvar-use + %delete-lvar-use)) +;;; Just delete NODE from its LVAR uses; LVAR is preserved so it may +;;; be given a new use. +(defun %delete-lvar-use (node) + (let ((lvar (node-lvar node))) + (when lvar + (if (listp (lvar-uses lvar)) + (let ((new-uses (delq node (lvar-uses lvar)))) + (setf (lvar-uses lvar) + (if (singleton-p new-uses) + (first new-uses) + new-uses))) + (setf (lvar-uses lvar) nil)) + (setf (node-lvar node) nil))) + (values)) +;;; Delete NODE from its LVAR uses; if LVAR has no other uses, delete +;;; its DEST's block, which must be unreachable. +(defun delete-lvar-use (node) + (let ((lvar (node-lvar node))) + (when lvar + (%delete-lvar-use node) + (if (null (lvar-uses lvar)) + (binding* ((dest (lvar-dest lvar) :exit-if-null) + (() (not (node-deleted dest)) :exit-if-null) + (block (node-block dest))) + (mark-for-deletion block)) + (reoptimize-lvar lvar)))) (values)) -;;; Update continuation use information so that NODE uses CONT. If -;;; CONT is :UNUSED, then we set its block to NODE's NODE-BLOCK (which -;;; must be set.) +;;; Update lvar use information so that NODE uses LVAR. ;;; ;;; Note: if you call this function, you may have to do a -;;; REOPTIMIZE-CONTINUATION to inform IR1 optimization that something -;;; has changed. -(declaim (ftype (function (node continuation) (values)) add-continuation-use)) -(defun add-continuation-use (node cont) - (aver (not (node-cont node))) - (let ((block (continuation-block cont))) - (ecase (continuation-kind cont) - (:deleted) - (:unused - (aver (not block)) - (let ((block (node-block node))) - (aver block) - (setf (continuation-block cont) block)) - (setf (continuation-kind cont) :inside-block) - (setf (continuation-use cont) node)) - ((:block-start :deleted-block-start) - (let ((uses (cons node (block-start-uses block)))) - (setf (block-start-uses block) uses) - (setf (continuation-use cont) - (if (cdr uses) nil (car uses))))))) - (setf (node-cont node) cont) +;;; REOPTIMIZE-LVAR to inform IR1 optimization that something has +;;; changed. +(declaim (ftype (sfunction (node (or lvar null)) (values)) add-lvar-use)) +(defun add-lvar-use (node lvar) + (aver (not (node-lvar node))) + (when lvar + (let ((uses (lvar-uses lvar))) + (setf (lvar-uses lvar) + (cond ((null uses) + node) + ((listp uses) + (cons node uses)) + (t + (list node uses)))) + (setf (node-lvar node) lvar))) + (values)) -;;; Return true if CONT is the NODE-CONT for NODE and CONT is -;;; transferred to immediately after the evaluation of NODE. -(defun immediately-used-p (cont node) - (declare (type continuation cont) (type node node)) - (and (eq (node-cont node) cont) - (not (eq (continuation-kind cont) :deleted)) - (let ((cblock (continuation-block cont)) - (nblock (node-block node))) - (or (eq cblock nblock) - (let ((succ (block-succ nblock))) - (and (= (length succ) 1) - (eq (first succ) cblock))))))) +;;; Return true if LVAR destination is executed immediately after +;;; NODE. Cleanups are ignored. +(defun immediately-used-p (lvar node) + (declare (type lvar lvar) (type node node)) + (aver (eq (node-lvar node) lvar)) + (let ((dest (lvar-dest lvar))) + (acond ((node-next node) + (eq (ctran-next it) dest)) + (t (eq (block-start (first (block-succ (node-block node)))) + (node-prev dest)))))) -;;;; continuation substitution +;;;; lvar substitution ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be -;;; NIL. When we are done, we call FLUSH-DEST on OLD to clear its DEST -;;; and to note potential optimization opportunities. -(defun substitute-continuation (new old) - (declare (type continuation old new)) - (aver (not (continuation-dest new))) - (let ((dest (continuation-dest old))) +;;; NIL. We do not flush OLD's DEST. +(defun substitute-lvar (new old) + (declare (type lvar old new)) + (aver (not (lvar-dest new))) + (let ((dest (lvar-dest old))) (etypecase dest ((or ref bind)) (cif (setf (if-test dest) new)) @@ -148,86 +155,164 @@ (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))) - (flush-dest old) - (setf (continuation-dest new) dest)) + (setf (lvar-dest old) nil) + (setf (lvar-dest new) dest) + (flush-lvar-externally-checkable-type new)) (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an -;;; arbitary number of uses. If NEW will end up with more than one -;;; use, then we must arrange for it to start a block if it doesn't -;;; already. -(defun substitute-continuation-uses (new old) - (declare (type continuation old new)) - (unless (and (eq (continuation-kind new) :unused) - (eq (continuation-kind old) :inside-block)) - (ensure-block-start new)) - - (do-uses (node old) - (delete-continuation-use node) - (add-continuation-use node new)) - (dolist (lexenv-use (continuation-lexenv-uses old)) - (setf (cadr lexenv-use) new)) - - (reoptimize-continuation new) +;;; arbitary number of uses. +(defun substitute-lvar-uses (new old) + (declare (type lvar old) + (type (or lvar null) new)) + + (cond (new (do-uses (node old) + (%delete-lvar-use node) + (add-lvar-use node new)) + (reoptimize-lvar new)) + (t (flush-dest old))) (values)) ;;;; block starting/creation -;;; Return the block that CONT is the start of, making a block if +;;; Return the block that CTRAN is the start of, making a block if ;;; necessary. This function is called by IR1 translators which may -;;; cause a continuation to be used more than once. Every continuation -;;; which may be used more than once must start a block by the time -;;; that anyone does a USE-CONTINUATION on it. +;;; cause a CTRAN to be used more than once. Every CTRAN which may be +;;; used more than once must start a block by the time that anyone +;;; does a USE-CTRAN on it. ;;; ;;; We also throw the block into the next/prev list for the ;;; *CURRENT-COMPONENT* so that we keep track of which blocks we have ;;; made. -(defun continuation-starts-block (cont) - (declare (type continuation cont)) - (ecase (continuation-kind cont) +(defun ctran-starts-block (ctran) + (declare (type ctran ctran)) + (ecase (ctran-kind ctran) (: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) + (aver (not (ctran-block ctran))) + (let* ((next (component-last-block *current-component*)) + (prev (block-prev next)) + (new-block (make-block ctran))) + (setf (block-next new-block) next + (block-prev new-block) prev + (block-prev next) new-block + (block-next prev) new-block + (ctran-block ctran) new-block + (ctran-kind ctran) :block-start) + (aver (not (ctran-use ctran))) new-block)) (:block-start - (continuation-block cont)))) - -;;; Ensure that CONT is the start of a block (or deleted) so that -;;; the use set can be freely manipulated. -;;; -- If the continuation is :UNUSED or is :INSIDE-BLOCK and the -;;; 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 -;;; continuation be a :BLOCK-START. -(defun ensure-block-start (cont) - (declare (type continuation cont)) - (let ((kind (continuation-kind cont))) + (ctran-block ctran)))) + +;;; Ensure that CTRAN is the start of a block so that the use set can +;;; be freely manipulated. +(defun ensure-block-start (ctran) + (declare (type ctran ctran)) + (let ((kind (ctran-kind ctran))) (ecase kind - ((:deleted :block-start :deleted-block-start)) - ((:unused :inside-block) - (let ((block (continuation-block cont))) - (cond ((or (eq kind :unused) - (eq (node-cont (block-last block)) cont)) - (setf (continuation-block cont) - (make-block-key :start cont - :component nil - :start-uses (find-uses cont))) - (setf (continuation-kind cont) :deleted-block-start)) - (t - (node-ends-block (continuation-use cont)))))))) + ((:block-start)) + ((:unused) + (setf (ctran-block ctran) + (make-block-key :start ctran)) + (setf (ctran-kind ctran) :block-start)) + ((:inside-block) + (node-ends-block (ctran-use ctran))))) + (values)) + +;;; CTRAN must be the last ctran in an incomplete block; finish the +;;; block and start a new one if necessary. +(defun start-block (ctran) + (declare (type ctran ctran)) + (aver (not (ctran-next ctran))) + (ecase (ctran-kind ctran) + (:inside-block + (let ((block (ctran-block ctran)) + (node (ctran-use ctran))) + (aver (not (block-last block))) + (aver node) + (setf (block-last block) node) + (setf (node-next node) nil) + (setf (ctran-use ctran) nil) + (setf (ctran-kind ctran) :unused) + (setf (ctran-block ctran) nil) + (link-blocks block (ctran-starts-block ctran)))) + (:block-start))) + +;;;; + +;;; Filter values of LVAR through FORM, which must be an ordinary/mv +;;; call. First argument must be 'DUMMY, which will be replaced with +;;; LVAR. In case of an ordinary call the function should not have +;;; return type NIL. We create a new "filtered" lvar. +;;; +;;; TODO: remove preconditions. +(defun filter-lvar (lvar form) + (declare (type lvar lvar) (type list form)) + (let* ((dest (lvar-dest lvar)) + (ctran (node-prev dest))) + (with-ir1-environment-from-node dest + + (ensure-block-start ctran) + (let* ((old-block (ctran-block ctran)) + (new-start (make-ctran)) + (filtered-lvar (make-lvar)) + (new-block (ctran-starts-block new-start))) + + ;; Splice in the new block before DEST, giving the new block + ;; all of DEST's predecessors. + (dolist (block (block-pred old-block)) + (change-block-successor block old-block new-block)) + + (ir1-convert new-start ctran filtered-lvar form) + + ;; 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 + + ;; Replace 'DUMMY with the LVAR. (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 lvar. We substitute for the first argument of + ;; this node. + (let* ((node (lvar-use filtered-lvar)) + (args (basic-combination-args node)) + (victim (first args))) + (aver (eq (constant-value (ref-leaf (lvar-use victim))) + 'dummy)) + + (substitute-lvar filtered-lvar lvar) + (substitute-lvar lvar victim) + (flush-dest victim)) + + ;; Invoking local call analysis converts this call to a LET. + (locall-analyze-component *current-component*)))) (values)) + +;;; Delete NODE and VALUE. It may result in some calls becoming tail. +(defun delete-filter (node lvar value) + (aver (eq (lvar-dest value) node)) + (aver (eq (node-lvar node) lvar)) + (cond (lvar (collect ((merges)) + (when (return-p (lvar-dest lvar)) + (do-uses (use value) + (when (and (basic-combination-p use) + (eq (basic-combination-kind use) :local)) + (merges use)))) + (%delete-lvar-use node) + (substitute-lvar-uses lvar value) + (prog1 + (unlink-node node) + (dolist (merge (merges)) + (merge-tail-sets merge))))) + (t (flush-dest value) + (unlink-node node)))) ;;;; miscellaneous shorthand functions @@ -239,34 +324,50 @@ (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) (lexenv-lambda (lambda-call-lexenv fun)))) - ((not (eq (functional-kind fun) :deleted)) + ((not (memq (functional-kind fun) '(:deleted :zombie))) (lambda-home fun)) (when (eq (lambda-home fun) fun) (return fun)))) +#!-sb-fluid (declaim (inline node-block)) (defun node-block (node) - (declare (type node node)) - (the cblock (continuation-block (node-prev node)))) + (ctran-block (node-prev node))) +(declaim (ftype (sfunction (node) component) node-component)) (defun node-component (node) - (declare (type node node)) (block-component (node-block node))) +(declaim (ftype (sfunction (node) physenv) node-physenv)) (defun node-physenv (node) - (declare (type node node)) - (the physenv (lambda-physenv (node-home-lambda node)))) - + (lambda-physenv (node-home-lambda node))) +#!-sb-fluid (declaim (inline node-dest)) +(defun node-dest (node) + (awhen (node-lvar node) (lvar-dest it))) + +(declaim (inline block-to-be-deleted-p)) +(defun block-to-be-deleted-p (block) + (or (block-delete-p block) + (eq (functional-kind (block-home-lambda block)) :deleted))) + +;;; Checks whether NODE is in a block to be deleted +(declaim (inline node-to-be-deleted-p)) +(defun node-to-be-deleted-p (node) + (block-to-be-deleted-p (node-block node))) + +(declaim (ftype (sfunction (clambda) cblock) lambda-block)) (defun lambda-block (clambda) - (declare (type clambda clambda)) (node-block (lambda-bind clambda))) +(declaim (ftype (sfunction (clambda) component) lambda-component)) (defun lambda-component (clambda) (block-component (lambda-block clambda))) +(declaim (ftype (sfunction (cblock) node) block-start-node)) +(defun block-start-node (block) + (ctran-next (block-start block))) + ;;; Return the enclosing cleanup for environment of the first or last ;;; node in BLOCK. (defun block-start-cleanup (block) - (declare (type cblock block)) - (node-enclosing-cleanup (continuation-next (block-start block)))) + (node-enclosing-cleanup (block-start-node block))) (defun block-end-cleanup (block) - (declare (type cblock block)) (node-enclosing-cleanup (block-last block))) ;;; Return the non-LET LAMBDA that holds BLOCK's code, or NIL @@ -277,8 +378,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)) @@ -308,13 +409,13 @@ nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. +(declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) (defun block-home-lambda (block) - (the clambda - (block-home-lambda-or-null block))) + (block-home-lambda-or-null block)) ;;; Return the IR1 physical environment for BLOCK. +(declaim (ftype (sfunction (cblock) physenv) block-physenv)) (defun block-physenv (block) - (declare (type cblock block)) (lambda-physenv (block-home-lambda block))) ;;; Return the Top Level Form number of PATH, i.e. the ordinal number @@ -351,44 +452,93 @@ (first forms) (values (find-original-source path))))) -;;; Return NODE-SOURCE-FORM, T if continuation has a single use, -;;; otherwise NIL, NIL. -(defun continuation-source (cont) - (let ((use (continuation-use cont))) - (if use - (values (node-source-form use) t) - (values nil nil)))) - -;;; Return the LAMBDA that is CONT's home, or NIL if there is none. -(defun continuation-home-lambda-or-null (cont) +;;; Return NODE-SOURCE-FORM, T if lvar has a single use, otherwise +;;; NIL, NIL. +(defun lvar-source (lvar) + (let ((use (lvar-uses lvar))) + (if (listp use) + (values nil nil) + (values (node-source-form use) t)))) + +;;; Return the unique node, delivering a value to LVAR. +#!-sb-fluid (declaim (inline lvar-use)) +(defun lvar-use (lvar) + (the (not list) (lvar-uses lvar))) + +#!-sb-fluid (declaim (inline lvar-has-single-use-p)) +(defun lvar-has-single-use-p (lvar) + (typep (lvar-uses lvar) '(not list))) + +;;; Return the LAMBDA that is CTRAN's home, or NIL if there is none. +(declaim (ftype (sfunction (ctran) (or clambda null)) + ctran-home-lambda-or-null)) +(defun ctran-home-lambda-or-null (ctran) ;; KLUDGE: This function is a post-CMU-CL hack by WHN, and this ;; implementation might not be quite right, or might be uglier than ;; necessary. It appears that the original Python never found a need ;; to do this operation. The obvious things based on - ;; NODE-HOME-LAMBDA of CONTINUATION-USE usually work; then if that - ;; fails, BLOCK-HOME-LAMBDA of CONTINUATION-BLOCK works, given that - ;; we generalize it enough to grovel harder when the simple CMU CL + ;; NODE-HOME-LAMBDA of CTRAN-USE usually work; then if that fails, + ;; BLOCK-HOME-LAMBDA of CTRAN-BLOCK works, given that we + ;; generalize it enough to grovel harder when the simple CMU CL ;; approach fails, and furthermore realize that in some exceptional ;; cases it might return NIL. -- WHN 2001-12-04 - (cond ((continuation-use cont) - (node-home-lambda (continuation-use cont))) - ((continuation-block cont) - (block-home-lambda-or-null (continuation-block cont))) + (cond ((ctran-use ctran) + (node-home-lambda (ctran-use ctran))) + ((ctran-block ctran) + (block-home-lambda-or-null (ctran-block ctran))) (t - (error "internal error: 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))) + (bug "confused about home lambda for ~S" ctran)))) + +;;; Return the LAMBDA that is CTRAN's home. +(declaim (ftype (sfunction (ctran) clambda) ctran-home-lambda)) +(defun ctran-home-lambda (ctran) + (ctran-home-lambda-or-null ctran)) + +(declaim (inline cast-single-value-p)) +(defun cast-single-value-p (cast) + (not (values-type-p (cast-asserted-type cast)))) + +#!-sb-fluid (declaim (inline lvar-single-value-p)) +(defun lvar-single-value-p (lvar) + (or (not lvar) + (let ((dest (lvar-dest lvar))) + (typecase dest + ((or creturn exit) + nil) + (mv-combination + (eq (basic-combination-fun dest) lvar)) + (cast + (locally + (declare (notinline lvar-single-value-p)) + (and (cast-single-value-p dest) + (lvar-single-value-p (node-lvar dest))))) + (t + t))))) + +(defun principal-lvar-end (lvar) + (loop for prev = lvar then (node-lvar dest) + for dest = (and prev (lvar-dest prev)) + while (cast-p dest) + finally (return (values dest prev)))) + +(defun principal-lvar-single-valuify (lvar) + (loop for prev = lvar then (node-lvar dest) + for dest = (and prev (lvar-dest prev)) + while (cast-p dest) + do (setf (node-derived-type dest) + (make-short-values-type (list (single-value-type + (node-derived-type dest))))) + (reoptimize-lvar 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*) - funs vars blocks tags type-restrictions options + funs vars blocks tags + type-restrictions (lambda (lexenv-lambda default)) (cleanup (lexenv-cleanup default)) + (handled-conditions (lexenv-handled-conditions default)) (policy (lexenv-policy default))) (macrolet ((frob (var slot) `(let ((old (,slot default))) @@ -401,8 +551,37 @@ (frob blocks lexenv-blocks) (frob tags lexenv-tags) (frob type-restrictions lexenv-type-restrictions) - lambda cleanup policy - (frob options lexenv-options)))) + lambda cleanup handled-conditions 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 + nil + nil + (lexenv-handled-conditions lexenv) + (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -416,9 +595,9 @@ (push block1 (block-pred block2)) (values)) (defun %link-blocks (block1 block2) - (declare (type cblock block1 block2) (inline member)) + (declare (type cblock block1 block2)) (let ((succ1 (block-succ block1))) - (aver (not (member block2 succ1 :test #'eq))) + (aver (not (memq block2 succ1))) (cons block2 succ1))) ;;; This is like LINK-BLOCKS, but we separate BLOCK1 and BLOCK2. If @@ -438,7 +617,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))))) @@ -450,7 +629,7 @@ ;;; BLOCK-TEST-MODIFIED so that any test constraint will be applied to ;;; the new successor. (defun change-block-successor (block old new) - (declare (type cblock new old block) (inline member)) + (declare (type cblock new old block)) (unlink-blocks block old) (let ((last (block-last block)) (comp (block-component block))) @@ -463,22 +642,25 @@ succ-left) (first succ-left) new))) - (unless (member new succ-left :test #'eq) + (unless (memq new succ-left) (link-blocks block new)) (macrolet ((frob (slot) `(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) + (unless (memq new (block-succ block)) (link-blocks block new))))) (values)) ;;; Unlink a block from the next/prev chain. We also null out the ;;; COMPONENT. -(declaim (ftype (function (cblock) (values)) remove-from-dfo)) +(declaim (ftype (sfunction (cblock) (values)) remove-from-dfo)) (defun remove-from-dfo (block) (let ((next (block-next block)) (prev (block-prev block))) @@ -488,7 +670,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)) @@ -501,9 +683,33 @@ (setf (block-prev next) block)) (values)) +;;; List all NLX-INFOs which BLOCK can exit to. +;;; +;;; We hope that no cleanup actions are performed in the middle of +;;; BLOCK, so it is enough to look only at cleanups in the block +;;; end. The tricky thing is a special cleanup block; all its nodes +;;; have the same cleanup info, corresponding to the start, so the +;;; same approach returns safe result. +(defun map-block-nlxes (fun block) + (loop for cleanup = (block-end-cleanup block) + then (node-enclosing-cleanup (cleanup-mess-up cleanup)) + while cleanup + do (let ((mess-up (cleanup-mess-up cleanup))) + (case (cleanup-kind cleanup) + ((:block :tagbody) + (aver (entry-p mess-up)) + (loop for exit in (entry-exits mess-up) + for nlx-info = (find-nlx-info exit) + do (funcall fun nlx-info))) + ((:catch :unwind-protect) + (aver (combination-p mess-up)) + (let* ((arg-lvar (first (basic-combination-args mess-up))) + (nlx-info (constant-value (ref-leaf (lvar-use arg-lvar))))) + (funcall fun nlx-info))))))) + ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. -(declaim (ftype (function (component) (values)) clear-flags)) +(declaim (ftype (sfunction (component) (values)) clear-flags)) (defun clear-flags (component) (let ((head (component-head component)) (tail (component-tail component))) @@ -515,11 +721,11 @@ ;;; Make a component with no blocks in it. The BLOCK-FLAG is initially ;;; true in the head and tail blocks. -(declaim (ftype (function nil component) make-empty-component)) +(declaim (ftype (sfunction () component) make-empty-component)) (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) @@ -533,88 +739,84 @@ (defun node-ends-block (node) (declare (type node node)) (let* ((block (node-block node)) - (start (node-cont node)) - (last (block-last block)) - (last-cont (node-cont last))) + (start (node-next node)) + (last (block-last block))) (unless (eq last node) - (aver (and (eq (continuation-kind start) :inside-block) - (not (block-delete-p block)))) + (aver (and (eq (ctran-kind start) :inside-block) + (not (block-delete-p block)))) (let* ((succ (block-succ block)) (new-block (make-block-key :start start :component (block-component block) - :start-uses (list (continuation-use start)) :succ succ :last last))) - (setf (continuation-kind start) :block-start) + (setf (ctran-kind start) :block-start) + (setf (ctran-use start) nil) + (setf (block-last block) node) + (setf (node-next node) nil) (dolist (b succ) (setf (block-pred b) (cons new-block (remove block (block-pred b))))) (setf (block-succ block) ()) - (setf (block-last block) node) (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) - (setf (continuation-block last-cont) new-block))) - (setf (continuation-block cont) new-block)) + + (do ((ctran start (node-next (ctran-next ctran)))) + ((not ctran)) + (setf (ctran-block ctran) new-block)) (setf (block-type-asserted block) t) (setf (block-test-modified block) t)))) - (values)) ;;;; 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)) - (let* ((cont (node-cont ref)) - (dest (continuation-dest cont))) + (let* ((lvar (node-lvar ref)) + (dest (and lvar (lvar-dest lvar)))) (when (and (combination-p dest) - (eq (basic-combination-fun dest) cont) + (eq (basic-combination-fun dest) lvar) (eq (basic-combination-kind dest) :local)) (let* ((args (basic-combination-args dest)) (arg (elt args n))) - (reoptimize-continuation arg) + (reoptimize-lvar arg) (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 - (continuation-dest - (node-cont - (first (leaf-refs fun))))) + (lvar-dest (node-lvar (first (leaf-refs fun))))) (cdr args)) (vars (lambda-vars fun) (cdr vars))) ((eq (car vars) var) - (reoptimize-continuation (car args)))))) + (reoptimize-lvar (car args)))))) (values)) ;;; Delete a function that has no references. This need only be called @@ -628,58 +830,86 @@ (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 -;;; 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)) - (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* ((bind-block (node-block bind)) - (component (block-component bind-block)) - (return (lambda-return leaf))) - (aver (null (leaf-refs leaf))) - (unless (leaf-ever-used leaf) - (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))) - (setf (component-reanalyze component) t) - (let ((tails (lambda-tail-set leaf))) - (setf (tail-set-funs tails) - (delete leaf (tail-set-funs tails))) - (setf (lambda-tail-set leaf) nil)) - (setf (component-lambdas component) - (delete leaf (component-lambdas component))))) - - (when (eq kind :external) - (let ((fun (functional-entry-fun leaf))) +;;; Deal with deleting the last reference to a CLAMBDA, which means +;;; that the lambda is unreachable, so that its body may be +;;; deleted. We set FUNCTIONAL-KIND to :DELETED and rely on +;;; IR1-OPTIMIZE to delete its blocks. +(defun delete-lambda (clambda) + (declare (type clambda clambda)) + (let ((original-kind (functional-kind clambda)) + (bind (lambda-bind clambda))) + (aver (not (member original-kind '(:deleted :toplevel)))) + (aver (not (functional-has-external-references-p clambda))) + (aver (or (eq original-kind :zombie) bind)) + (setf (functional-kind clambda) :deleted) + (setf (lambda-bind clambda) nil) + + (labels ((delete-children (lambda) + (dolist (child (lambda-children lambda)) + (cond ((eq (functional-kind child) :deleted) + (delete-children child)) + (t + (delete-lambda child)))) + (setf (lambda-children lambda) nil) + (setf (lambda-parent lambda) nil))) + (delete-children clambda)) + + ;; (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.) + (case original-kind + (:zombie) + ((:let :mv-let :assignment) + (let ((bind-block (node-block bind))) + (mark-for-deletion bind-block)) + (let ((home (lambda-home clambda))) + (setf (lambda-lets home) (delete clambda (lambda-lets home)))) + ;; KLUDGE: In presence of NLEs we cannot always understand that + ;; LET's BIND dominates its body [for a LET "its" body is not + ;; quite its]; let's delete too dangerous for IR2 stuff. -- + ;; APD, 2004-01-01 + (dolist (var (lambda-vars clambda)) + (flet ((delete-node (node) + (mark-for-deletion (node-block node)))) + (mapc #'delete-node (leaf-refs var)) + (mapc #'delete-node (lambda-var-sets var))))) + (t + ;; Function has no reachable references. + (dolist (ref (lambda-refs clambda)) + (mark-for-deletion (node-block ref))) + ;; 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 clambda)) + (return-block (and return (node-block return)))) + (unless (leaf-ever-used clambda) + (let ((*compiler-error-context* bind)) + (compiler-notify 'code-deletion-note + :format-control "deleting unused function~:[.~;~:*~% ~S~]" + :format-arguments (list (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 clambda))) + (setf (tail-set-funs tails) + (delete clambda (tail-set-funs tails))) + (setf (lambda-tail-set clambda) nil)) + (setf (component-lambdas component) + (delq clambda (component-lambdas component)))))) + + ;; 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))))) @@ -699,11 +929,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))) @@ -723,9 +953,10 @@ (maybe-convert-to-assignment fun))) (t (maybe-convert-to-assignment fun))))))) - + (dolist (ep (optional-dispatch-entry-points leaf)) - (frob ep)) + (when (promise-ready-p ep) + (frob (force ep)))) (when (optional-dispatch-more-entry leaf) (frob (optional-dispatch-more-entry leaf))) (let ((main (optional-dispatch-main-entry leaf))) @@ -740,7 +971,7 @@ (defun delete-ref (ref) (declare (type ref ref)) (let* ((leaf (ref-leaf ref)) - (refs (delete ref (leaf-refs leaf)))) + (refs (delq ref (leaf-refs leaf)))) (setf (leaf-refs leaf) refs) (cond ((null refs) @@ -750,11 +981,11 @@ (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)) - ((:deleted :optional)))) + ((:deleted :zombie :optional)))) (optional-dispatch (unless (eq (functional-kind leaf) :deleted) (delete-optional-dispatch leaf))))) @@ -770,170 +1001,147 @@ (values)) ;;; This function is called by people who delete nodes; it provides a -;;; way to indicate that the value of a continuation is no longer -;;; used. We null out the CONTINUATION-DEST, set FLUSH-P in the blocks -;;; 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 -;;; 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 -;;; SUBSTITUTE-CONTINUATION), so we don't want to delete it. -(defun flush-dest (cont) - (declare (type continuation cont)) - - (unless (eq (continuation-kind cont) :deleted) - (aver (continuation-dest cont)) - (setf (continuation-dest cont) nil) - (do-uses (use cont) +;;; way to indicate that the value of a lvar is no longer used. We +;;; null out the LVAR-DEST, set FLUSH-P in the blocks containing uses +;;; of LVAR and set COMPONENT-REOPTIMIZE. +(defun flush-dest (lvar) + (declare (type (or lvar null) lvar)) + (unless (null lvar) + (setf (lvar-dest lvar) nil) + (flush-lvar-externally-checkable-type lvar) + (do-uses (use lvar) (let ((prev (node-prev use))) - (unless (eq (continuation-kind prev) :deleted) - (let ((block (continuation-block prev))) - (setf (component-reoptimize (block-component block)) t) - (setf (block-attributep (block-flags block) flush-p type-asserted) - t)))))) + (let ((block (ctran-block prev))) + (setf (component-reoptimize (block-component block)) t) + (setf (block-attributep (block-flags block) + flush-p type-asserted type-check) + t))) + (setf (node-lvar use) nil)) + (setf (lvar-uses lvar) nil)) + (values)) - (setf (continuation-%type-check cont) nil) +(defun delete-dest (lvar) + (when lvar + (let* ((dest (lvar-dest lvar)) + (prev (node-prev dest))) + (let ((block (ctran-block prev))) + (unless (block-delete-p block) + (mark-for-deletion block)))))) - (values)) +;;; Queue the block for deletion +(defun delete-block-lazily (block) + (declare (type cblock block)) + (unless (block-delete-p block) + (setf (block-delete-p block) t) + (push block (component-delete-blocks (block-component 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))) - (values)) - -;;; Delete CONT, eliminating both control and value semantics. We set -;;; FLUSH-P and COMPONENT-REOPTIMIZE similarly to in FLUSH-DEST. Here -;;; we must get the component from the use block, since the -;;; continuation may be a :DELETED-BLOCK-START. -;;; -;;; If CONT has DEST, then it must be the case that the DEST is -;;; unreachable, since we can't compute the value desired. In this -;;; case, we call MARK-FOR-DELETION to cause the DEST block and its -;;; predecessors to tell people to ignore them, and to cause them to -;;; be deleted eventually. -(defun delete-continuation (cont) - (declare (type continuation cont)) - (aver (not (eq (continuation-kind cont) :deleted))) - - (do-uses (use cont) - (let ((prev (node-prev use))) - (unless (eq (continuation-kind prev) :deleted) - (let ((block (continuation-block prev))) - (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))))))) - - (setf (continuation-kind cont) :deleted) - (setf (continuation-dest cont) nil) - (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) - + (let* ((component (block-component block)) + (head (component-head component))) + (labels ((helper (block) + (delete-block-lazily block) + (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)) ;;; This function does what is necessary to eliminate the code in it ;;; from the IR1 representation. This involves unlinking it from its ;;; predecessors and successors and deleting various node-specific -;;; semantic information. -;;; -;;; We mark the START as has having no next and remove the last node -;;; from its CONT's uses. We also flush the DEST for all continuations -;;; whose values are received by nodes in the block. -(defun delete-block (block) +;;; semantic information. BLOCK must be already removed from +;;; COMPONENT-DELETE-BLOCKS. +(defun delete-block (block &optional silent) (declare (type cblock block)) - (aver (block-component block)) ; else block is already deleted! - (note-block-deletion block) + (aver (block-component block)) ; else block is already deleted! + #!+high-security (aver (not (memq block (component-delete-blocks (block-component block))))) + (unless silent + (note-block-deletion block)) (setf (block-delete-p block) t) - (let* ((last (block-last block)) - (cont (node-cont last))) - (delete-continuation-use last) - (if (eq (continuation-kind cont) :unused) - (delete-continuation cont) - (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)) - (do-nodes (node cont block) - (typecase node + (do-nodes-carefully (node block) + (when (valued-node-p node) + (delete-lvar-use node)) + (etypecase node (ref (delete-ref node)) - (cif - (flush-dest (if-test node))) + (cif (flush-dest (if-test node))) ;; The next two cases serve to maintain the invariant that a LET ;; always has a well-formed COMBINATION, REF and BIND. We delete ;; the lambda whenever we delete any of these, but we must be ;; careful that this LET has not already been partially deleted. (basic-combination (when (and (eq (basic-combination-kind node) :local) - ;; 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)) - (eq (let-combination fun) node)) - (delete-lambda fun)))) + ;; Guards COMBINATION-LAMBDA agains the REF being deleted. + (lvar-uses (basic-combination-fun node))) + (let ((fun (combination-lambda node))) + ;; 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)) (dolist (arg (basic-combination-args node)) - (when arg (flush-dest arg)))) + (when arg (flush-dest arg)))) (bind (let ((lambda (bind-lambda node))) - (unless (eq (functional-kind lambda) :deleted) - (aver (member (functional-kind lambda) '(:let :mv-let :assignment))) - (delete-lambda lambda)))) + (unless (eq (functional-kind lambda) :deleted) + (delete-lambda lambda)))) (exit (let ((value (exit-value node)) - (entry (exit-entry node))) - (when value - (flush-dest value)) - (when entry - (setf (entry-exits entry) - (delete node (entry-exits entry)))))) + (entry (exit-entry node))) + (when value + (flush-dest value)) + (when entry + (setf (entry-exits entry) + (delq node (entry-exits entry)))))) + (entry + (dolist (exit (entry-exits node)) + (mark-for-deletion (node-block exit))) + (let ((home (node-home-lambda node))) + (setf (lambda-entries home) (delq node (lambda-entries home))))) (creturn (flush-dest (return-result node)) (delete-return node)) (cset (flush-dest (set-value node)) (let ((var (set-var node))) - (setf (basic-var-sets var) - (delete node (basic-var-sets var)))))) - - (delete-continuation (node-prev node))) + (setf (basic-var-sets var) + (delete node (basic-var-sets var))))) + (cast + (flush-dest (cast-value 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 @@ -947,8 +1155,14 @@ (unless (policy *compiler-error-context* (= inhibit-warnings 3)) ;; ANSI section "3.2.5 Exceptional Situations in the Compiler" ;; requires this to be no more than a STYLE-WARNING. + #-sb-xc-host (compiler-style-warn "The variable ~S is defined but never used." - (leaf-debug-name var))) + (leaf-debug-name var)) + ;; There's no reason to accept this kind of equivocation + ;; when compiling our own code, though. + #+sb-xc-host + (compiler-warn "The variable ~S is defined but never used." + (leaf-debug-name var))) (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN (values)) @@ -1000,7 +1214,7 @@ (defun note-block-deletion (block) (let ((home (block-home-lambda block))) (unless (eq (functional-kind home) :deleted) - (do-nodes (node cont block) + (do-nodes (node nil block) (let* ((path (node-source-path node)) (first (first path))) (when (or (eq first 'original-source-start) @@ -1018,17 +1232,14 @@ 0))) (unless (return-p node) (let ((*compiler-error-context* node)) - (compiler-note "deleting unreachable code"))) + (compiler-notify 'code-deletion-note + :format-control "deleting unreachable code" + :format-arguments nil))) (return)))))) (values)) ;;; Delete a node from a block, deleting the block if there are no -;;; nodes left. We remove the node from the uses of its CONT, but we -;;; don't deal with cleaning up any type-specific semantic -;;; attachments. If the CONT is :UNUSED after deleting this use, then -;;; we delete CONT. (Note :UNUSED is not the same as no uses. A -;;; continuation will only become :UNUSED if it was :INSIDE-BLOCK -;;; before.) +;;; nodes left. We remove the node from the uses of its LVAR. ;;; ;;; If the node is the last node, there must be exactly one successor. ;;; We link all of our precedessors to the successor and unlink the @@ -1039,19 +1250,16 @@ ;;; empty blocks in IR1. (defun unlink-node (node) (declare (type node node)) - (let* ((cont (node-cont node)) - (next (continuation-next cont)) + (when (valued-node-p node) + (delete-lvar-use node)) + + (let* ((ctran (node-next node)) + (next (and ctran (ctran-next ctran))) (prev (node-prev node)) - (block (continuation-block prev)) - (prev-kind (continuation-kind prev)) + (block (ctran-block prev)) + (prev-kind (ctran-kind prev)) (last (block-last block))) - (unless (eq (continuation-kind cont) :deleted) - (delete-continuation-use node) - (when (eq (continuation-kind cont) :unused) - (aver (not (continuation-dest cont))) - (delete-continuation cont))) - (setf (block-type-asserted block) t) (setf (block-test-modified block) t) @@ -1059,11 +1267,13 @@ (and (eq prev-kind :block-start) (not (eq node last)))) (cond ((eq node last) - (setf (block-last block) (continuation-use prev)) - (setf (continuation-next prev) nil)) + (setf (block-last block) (ctran-use prev)) + (setf (node-next (ctran-use prev)) nil)) (t - (setf (continuation-next prev) next) - (setf (node-prev next) prev))) + (setf (ctran-next prev) next) + (setf (node-prev next) prev) + (when (if-p next) ; AOP wanted + (reoptimize-lvar (if-test next))))) (setf (node-prev node) nil) nil) (t @@ -1071,15 +1281,13 @@ (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) + ((eq block (first succ)) (with-ir1-environment-from-node node - (let ((exit (make-exit)) - (dummy (make-continuation))) - (setf (continuation-next prev) nil) - (link-node-to-previous-continuation exit prev) - (add-continuation-use exit dummy) + (let ((exit (make-exit))) + (setf (ctran-next prev) nil) + (link-node-to-previous-ctran exit prev) (setf (block-last block) exit))) (setf (node-prev node) nil) nil) @@ -1089,12 +1297,12 @@ (unlink-blocks block next) (dolist (pred (block-pred block)) (change-block-successor pred block next)) - (remove-from-dfo block) - (cond ((continuation-dest prev) - (setf (continuation-next prev) nil) - (setf (continuation-kind prev) :deleted-block-start)) - (t - (delete-continuation prev))) + (when (block-delete-p block) + (let ((component (block-component block))) + (setf (component-delete-blocks component) + (delq block (component-delete-blocks component))))) + (remove-from-dfo block) + (setf (block-delete-p block) t) (setf (node-prev node) nil) t))))))) @@ -1104,8 +1312,7 @@ (declare (type node node)) (let ((prev (node-prev node))) (not (and prev - (not (eq (continuation-kind prev) :deleted)) - (let ((block (continuation-block prev))) + (let ((block (ctran-block prev))) (and (block-component block) (not (block-delete-p block)))))))) @@ -1114,19 +1321,30 @@ ;;; 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)) + (delete-block-lazily block)) (dolist (fun (component-lambdas component)) - (setf (functional-kind fun) nil) - (setf (functional-entry-fun fun) nil) - (setf (leaf-refs fun) nil) - (delete-functional fun)) - (do-blocks (block component) - (delete-block block)) + (unless (eq (functional-kind fun) :deleted) + (setf (functional-kind fun) nil) + (setf (functional-entry-fun fun) nil) + (setf (leaf-refs fun) nil) + (delete-functional fun))) + (clean-component component) (values)) +;;; Remove all pending blocks to be deleted. Return the nearest live +;;; block after or equal to BLOCK. +(defun clean-component (component &optional block) + (loop while (component-delete-blocks component) + ;; actual deletion of a block may queue new blocks + do (let ((current (pop (component-delete-blocks component)))) + (when (eq block current) + (setq block (block-next block))) + (delete-block current))) + block) + ;;; Convert code of the form ;;; (FOO ... (FUN ...) ...) ;;; to @@ -1137,41 +1355,51 @@ ;;; of arguments changes, the transform must be prepared to return a ;;; lambda with a new lambda-list with the correct number of ;;; arguments. -(defun extract-fun-args (cont fun num-args) +(defun extract-fun-args (lvar fun num-args) #!+sb-doc - "If CONT is a call to FUN with NUM-ARGS args, change those arguments - to feed directly to the continuation-dest of CONT, which must be - a combination." - (declare (type continuation cont) + "If LVAR is a call to FUN with NUM-ARGS args, change those arguments + to feed directly to the LVAR-DEST of LVAR, which must be a + combination." + (declare (type lvar lvar) (type symbol fun) (type index num-args)) - (let ((outside (continuation-dest cont)) - (inside (continuation-use cont))) + (let ((outside (lvar-dest lvar)) + (inside (lvar-uses lvar))) (aver (combination-p outside)) (unless (combination-p inside) (give-up-ir1-transform)) (let ((inside-fun (combination-fun inside))) - (unless (eq (continuation-fun-name inside-fun) fun) + (unless (eq (lvar-fun-name inside-fun) fun) (give-up-ir1-transform)) (let ((inside-args (combination-args inside))) (unless (= (length inside-args) num-args) (give-up-ir1-transform)) (let* ((outside-args (combination-args outside)) - (arg-position (position cont outside-args)) + (arg-position (position lvar outside-args)) (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 (lvar-dest arg) outside) + (flush-lvar-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) + (change-ref-leaf (lvar-uses inside-fun) (find-free-fun 'list "???")) - (setf (combination-kind inside) :full) + (setf (combination-fun-info inside) (info :function :info 'list) + (combination-kind inside) :known) (setf (node-derived-type inside) *wild-type*) - (flush-dest cont) - (setf (continuation-asserted-type cont) *wild-type*) + (flush-dest lvar) (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 @@ -1182,11 +1410,17 @@ (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))) - (reoptimize-continuation (node-cont ref))) + (setf (leaf-ever-used leaf) t) + (let* ((ltype (leaf-type leaf)) + (vltype (make-single-value-type ltype))) + (if (let* ((lvar (node-lvar ref)) + (dest (and lvar (lvar-dest lvar)))) + (and (basic-combination-p dest) + (eq lvar (basic-combination-fun dest)) + (csubtypep ltype (specifier-type 'function)))) + (setf (node-derived-type ref) vltype) + (derive-node-type ref vltype))) + (reoptimize-lvar (node-lvar ref))) (values)) ;;; Change all REFS for OLD-LEAF to NEW-LEAF. @@ -1224,19 +1458,34 @@ :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 #'neq))) + (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) - (declare (type entry entry) (type continuation cont)) - (let ((entry-cleanup (entry-cleanup entry))) +(defun find-nlx-info (exit) + (declare (type exit exit)) + (let ((entry (exit-entry exit))) (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) - (when (and (eq (nlx-info-continuation nlx) cont) - (eq (nlx-info-cleanup nlx) entry-cleanup)) + (when (eq (nlx-info-exit nlx) exit) (return nlx))))) ;;;; functional hackery -(declaim (ftype (function (functional) clambda) main-entry)) +(declaim (ftype (sfunction (functional) clambda) main-entry)) (defun main-entry (functional) (etypecase functional (clambda functional) @@ -1247,7 +1496,7 @@ ;;; MV-BIND when it appears in an MV-CALL. All fixed arguments must be ;;; optional with null default and no SUPPLIED-P. There must be a ;;; &REST arg with no references. -(declaim (ftype (function (functional) boolean) looks-like-an-mv-bind)) +(declaim (ftype (sfunction (functional) boolean) looks-like-an-mv-bind)) (defun looks-like-an-mv-bind (functional) (and (optional-dispatch-p functional) (do ((arg (optional-dispatch-arglist functional) (cdr arg))) @@ -1270,12 +1519,12 @@ (declare (type functional fun)) (not (null (member (functional-kind fun) '(:external :toplevel))))) -;;; If CONT's only use is a non-notinline global function reference, +;;; If LVAR's only use is a non-notinline global function reference, ;;; then return the referenced symbol, otherwise NIL. If NOTINLINE-OK ;;; is true, then we don't care if the leaf is NOTINLINE. -(defun continuation-fun-name (cont &optional notinline-ok) - (declare (type continuation cont)) - (let ((use (continuation-use cont))) +(defun lvar-fun-name (lvar &optional notinline-ok) + (declare (type lvar lvar)) + (let ((use (lvar-uses lvar))) (if (ref-p use) (let ((leaf (ref-leaf use))) (if (and (global-var-p leaf) @@ -1287,14 +1536,20 @@ 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 (lvar-uses (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))) - (continuation-dest (node-cont (first (leaf-refs fun))))) + (aver (functional-letlike-p fun)) + (lvar-dest (node-lvar (first (leaf-refs fun))))) -;;; Return the initial value continuation for a LET variable, or NIL -;;; if there is none. +;;; Return the initial value lvar for a LET variable, or NIL if there +;;; is none. (defun let-var-initial-value (var) (declare (type lambda-var var)) (let ((fun (lambda-var-home var))) @@ -1305,7 +1560,7 @@ (defun combination-lambda (call) (declare (type basic-combination call)) (aver (eq (basic-combination-kind call) :local)) - (ref-leaf (continuation-use (basic-combination-fun call)))) + (ref-leaf (lvar-uses (basic-combination-fun call)))) (defvar *inline-expansion-limit* 200 #!+sb-doc @@ -1332,83 +1587,166 @@ ;; compiler to be able to use WITH-COMPILATION-UNIT on ;; arbitrarily huge blocks of code. -- WHN) (let ((*compiler-error-context* node)) - (compiler-note "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ - probably trying to~% ~ - inline a recursive function." - *inline-expansion-limit*)) + (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ + probably trying to~% ~ + inline a recursive function." + *inline-expansion-limit*)) nil) (t t)))) + +;;; Make sure that FUNCTIONAL is not let-converted or deleted. +(defun assure-functional-live-p (functional) + (declare (type functional functional)) + (when (and (or + ;; looks LET-converted + (functional-somewhat-letlike-p functional) + ;; It's possible for a LET-converted function to end up + ;; deleted later. In that case, for the purposes of this + ;; analysis, it is LET-converted: LET-converted functionals + ;; are too badly trashed to expand them inline, and deleted + ;; LET-converted functionals are even worse. + (memq (functional-kind functional) '(:deleted :zombie)))) + (throw 'locall-already-let-converted functional))) + +(defun call-full-like-p (call) + (declare (type combination call)) + (let ((kind (basic-combination-kind call))) + (or (eq kind :full) + (and (eq kind :known) + (let ((info (basic-combination-fun-info call))) + (and + (not (fun-info-ir2-convert info)) + (dolist (template (fun-info-templates info) t) + (when (eq (template-ltn-policy template) :fast-safe) + (multiple-value-bind (val win) + (valid-fun-use call (template-type template)) + (when (or val (not win)) (return nil))))))))))) ;;;; careful call ;;; 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 (sfunction ((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) + (sb!kernel::arg-count-error (condition) + (values nil (list (format nil "~A" condition)))) + (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 ;;; This function is used by the result of PARSE-DEFTRANSFORM to find -;;; the continuation for the value of the &KEY argument KEY in the -;;; list of continuations ARGS. It returns the continuation if the -;;; keyword is present, or NIL otherwise. The legality and -;;; constantness of the keywords should already have been checked. -(declaim (ftype (function (list keyword) (or continuation null)) - find-keyword-continuation)) -(defun find-keyword-continuation (args key) +;;; the lvar for the value of the &KEY argument KEY in the list of +;;; lvars ARGS. It returns the lvar if the keyword is present, or NIL +;;; otherwise. The legality and constantness of the keywords should +;;; already have been checked. +(declaim (ftype (sfunction (list keyword) (or lvar null)) + find-keyword-lvar)) +(defun find-keyword-lvar (args key) (do ((arg args (cddr arg))) ((null arg) nil) - (when (eq (continuation-value (first arg)) key) + (when (eq (lvar-value (first arg)) key) (return (second arg))))) ;;; This function is used by the result of PARSE-DEFTRANSFORM to -;;; verify that alternating continuations in ARGS are constant and -;;; that there is an even number of args. -(declaim (ftype (function (list) boolean) check-key-args-constant)) +;;; verify that alternating lvars in ARGS are constant and that there +;;; is an even number of args. +(declaim (ftype (sfunction (list) boolean) check-key-args-constant)) (defun check-key-args-constant (args) (do ((arg args (cddr arg))) ((null arg) t) (unless (and (rest arg) - (constant-continuation-p (first arg))) + (constant-lvar-p (first arg))) (return nil)))) ;;; This function is used by the result of PARSE-DEFTRANSFORM to -;;; verify that the list of continuations ARGS is a well-formed &KEY -;;; arglist and that only keywords present in the list KEYS are -;;; supplied. -(declaim (ftype (function (list list) boolean) check-transform-keys)) +;;; verify that the list of lvars ARGS is a well-formed &KEY arglist +;;; and that only keywords present in the list KEYS are supplied. +(declaim (ftype (sfunction (list list) boolean) check-transform-keys)) (defun check-transform-keys (args keys) (and (check-key-args-constant args) (do ((arg args (cddr arg))) ((null arg) t) - (unless (member (continuation-value (first arg)) keys) + (unless (member (lvar-value (first arg)) keys) (return nil))))) ;;;; miscellaneous ;;; Called by the expansion of the EVENT macro. -(declaim (ftype (function (event-info (or node null)) *) %event)) +(declaim (ftype (sfunction (event-info (or node null)) *) %event)) (defun %event (info node) (incf (event-info-count info)) (when (and (>= (event-info-level info) *event-note-threshold*) (policy (or node *lexenv*) (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) - (compiler-note (event-info-description info)))) + (compiler-notify (event-info-description info)))) (let ((action (event-info-action info))) (when action (funcall action node)))) + +;;; +(defun make-cast (value type policy) + (declare (type lvar 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-lvar (lvar) + (declare (type (or lvar null) lvar)) + (when lvar + (let ((use (lvar-uses lvar))) + (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 (listp use) (combination-p use)) + (do-uses (node lvar) + (setf (node-reoptimize node) t) + (setf (block-reoptimize (node-block node)) t) + (setf (component-reoptimize (node-component node)) t)))))))