X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=d501d6708212db4d03195f932793c2fb09941b1d;hb=e840f481796d191997a47421d60cd039cd260613;hp=e0477c2ee5611e660ad9b23fdf195ea8820ee987;hpb=6053e7f804b430144bb09e2d107ad4ab3fb97db4;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index e0477c2..d501d67 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -20,7 +20,7 @@ (defun node-enclosing-cleanup (node) (declare (type node node)) (do ((lexenv (node-lexenv node) - (lambda-call-lexenv (lexenv-lambda lexenv)))) + (lambda-call-lexenv (lexenv-lambda lexenv)))) ((null lexenv) nil) (let ((cup (lexenv-cleanup lexenv))) (when cup (return cup))))) @@ -34,7 +34,7 @@ ;;; that cleanup. (defun insert-cleanup-code (block1 block2 node form &optional cleanup) (declare (type cblock block1 block2) (type node node) - (type (or cleanup null) cleanup)) + (type (or cleanup null) cleanup)) (setf (component-reanalyze (block-component block1)) t) (with-ir1-environment-from-node node (with-component-last-block (*current-component* @@ -62,11 +62,23 @@ uses (list uses)))) +(declaim (ftype (sfunction (lvar) lvar) principal-lvar)) +(defun principal-lvar (lvar) + (labels ((pl (lvar) + (let ((use (lvar-uses lvar))) + (if (cast-p use) + (pl (cast-value use)) + lvar)))) + (pl lvar))) + (defun principal-lvar-use (lvar) - (let ((use (lvar-uses lvar))) - (if (cast-p use) - (principal-lvar-use (cast-value use)) - use))) + (labels ((plu (lvar) + (declare (type lvar lvar)) + (let ((use (lvar-uses lvar))) + (if (cast-p use) + (plu (cast-value use)) + use)))) + (plu lvar))) ;;; Update lvar use information so that NODE is no longer a use of its ;;; LVAR. @@ -80,7 +92,7 @@ ;;; 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))) + (let ((lvar (node-lvar node))) (when lvar (if (listp (lvar-uses lvar)) (let ((new-uses (delq node (lvar-uses lvar)))) @@ -131,12 +143,11 @@ (defun immediately-used-p (lvar node) (declare (type lvar lvar) (type node node)) (aver (eq (node-lvar node) lvar)) - (and (eq (lvar-dest lvar) - (acond ((node-next node) - (ctran-next it)) - (t (let* ((block (node-block node)) - (next-block (first (block-succ block)))) - (block-start-node next-block))))))) + (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)))))) ;;;; lvar substitution @@ -154,9 +165,9 @@ (exit (setf (exit-value dest) new)) (basic-combination (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))))) + (setf (basic-combination-fun dest) new) + (setf (basic-combination-args dest) + (nsubst new old (basic-combination-args dest))))) (cast (setf (cast-value dest) new))) (setf (lvar-dest old) nil) @@ -165,17 +176,27 @@ (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an -;;; arbitary number of uses. -(defun substitute-lvar-uses (new old) +;;; arbitary number of uses. NEW is supposed to be "later" than OLD. +(defun substitute-lvar-uses (new old propagate-dx) (declare (type lvar old) - (type (or lvar null) new)) + (type (or lvar null) new) + (type boolean propagate-dx)) + + (cond (new + (do-uses (node old) + (%delete-lvar-use node) + (add-lvar-use node new)) + (reoptimize-lvar new) + (awhen (and propagate-dx (lvar-dynamic-extent old)) + (setf (lvar-dynamic-extent old) nil) + (unless (lvar-dynamic-extent new) + (setf (lvar-dynamic-extent new) it) + (setf (cleanup-info it) (subst new old (cleanup-info it))))) + (when (lvar-dynamic-extent new) + (do-uses (node new) + (node-ends-block node)))) + (t (flush-dest old))) - (do-uses (node old) - (%delete-lvar-use node) - (when new - (add-lvar-use node new))) - - (when new (reoptimize-lvar new)) (values)) ;;;; block starting/creation @@ -222,6 +243,25 @@ ((: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))) ;;;; @@ -288,14 +328,35 @@ (when (and (basic-combination-p use) (eq (basic-combination-kind use) :local)) (merges use)))) + (substitute-lvar-uses lvar value + (and lvar (eq (lvar-uses lvar) node))) (%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)))) + +;;; Make a CAST and insert it into IR1 before node NEXT. +(defun insert-cast-before (next lvar type policy) + (declare (type node next) (type lvar lvar) (type ctype type)) + (with-ir1-environment-from-node next + (let* ((ctran (node-prev next)) + (cast (make-cast lvar type policy)) + (internal-ctran (make-ctran))) + (setf (ctran-next ctran) cast + (node-prev cast) ctran) + (use-ctran cast internal-ctran) + (link-node-to-previous-ctran next internal-ctran) + (setf (lvar-dest lvar) cast) + (reoptimize-lvar lvar) + (when (return-p next) + (node-ends-block cast)) + (setf (block-attributep (block-flags (node-block cast)) + type-check type-asserted) + t) + cast))) ;;;; miscellaneous shorthand functions @@ -306,8 +367,8 @@ (defun node-home-lambda (node) (declare (type node node)) (do ((fun (lexenv-lambda (node-lexenv node)) - (lexenv-lambda (lambda-call-lexenv fun)))) - ((not (eq (functional-kind fun) :deleted)) + (lexenv-lambda (lambda-call-lexenv fun)))) + ((not (memq (functional-kind fun) '(:deleted :zombie))) (lambda-home fun)) (when (eq (lambda-home fun) fun) (return fun)))) @@ -325,6 +386,130 @@ (defun node-dest (node) (awhen (node-lvar node) (lvar-dest it))) +#!-sb-fluid (declaim (inline node-stack-allocate-p)) +(defun node-stack-allocate-p (node) + (awhen (node-lvar node) + (lvar-dynamic-extent it))) + +(declaim (ftype (sfunction (node (member nil t :truly) &optional (or null component)) + boolean) use-good-for-dx-p)) +(declaim (ftype (sfunction (lvar (member nil t :truly) &optional (or null component)) + boolean) lvar-good-for-dx-p)) +(defun use-good-for-dx-p (use dx &optional component) + ;; FIXME: Can casts point to LVARs in other components? + ;; RECHECK-DYNAMIC-EXTENT-LVARS assumes that they can't -- that is, that the + ;; PRINCIPAL-LVAR is always in the same component as the original one. It + ;; would be either good to have an explanation of why casts don't point + ;; across components, or an explanation of when they do it. ...in the + ;; meanwhile AVER that our assumption holds true. + (aver (or (not component) (eq component (node-component use)))) + (or (dx-combination-p use dx) + (and (cast-p use) + (not (cast-type-check use)) + (lvar-good-for-dx-p (cast-value use) dx component)) + (and (trivial-lambda-var-ref-p use) + (let ((uses (lvar-uses (trivial-lambda-var-ref-lvar use)))) + (or (eq use uses) + (lvar-good-for-dx-p (trivial-lambda-var-ref-lvar use) dx component)))))) + +(defun lvar-good-for-dx-p (lvar dx &optional component) + (let ((uses (lvar-uses lvar))) + (if (listp uses) + (every (lambda (use) + (use-good-for-dx-p use dx component)) + uses) + (use-good-for-dx-p uses dx component)))) + +(defun known-dx-combination-p (use dx) + (and (eq (combination-kind use) :known) + (let ((info (combination-fun-info use))) + (or (awhen (fun-info-stack-allocate-result info) + (funcall it use dx)) + (awhen (fun-info-result-arg info) + (let ((args (combination-args use))) + (lvar-good-for-dx-p (if (zerop it) + (car args) + (nth it args)) + dx))))))) + +(defun dx-combination-p (use dx) + (and (combination-p use) + (or + ;; Known, and can do DX. + (known-dx-combination-p use dx) + ;; Possibly a not-yet-eliminated lambda which ends up returning the + ;; results of an actual known DX combination. + (let* ((fun (combination-fun use)) + (ref (principal-lvar-use fun)) + (clambda (when (ref-p ref) + (ref-leaf ref))) + (creturn (when (lambda-p clambda) + (lambda-return clambda))) + (result-use (when (return-p creturn) + (principal-lvar-use (return-result creturn))))) + ;; FIXME: We should be able to deal with multiple uses here as well. + (and (dx-combination-p result-use dx) + (combination-args-flow-cleanly-p use result-use dx)))))) + +(defun combination-args-flow-cleanly-p (combination1 combination2 dx) + (labels ((recurse (combination) + (or (eq combination combination2) + (if (known-dx-combination-p combination dx) + (let ((dest (lvar-dest (combination-lvar combination)))) + (and (combination-p dest) + (recurse dest))) + (let* ((fun1 (combination-fun combination)) + (ref1 (principal-lvar-use fun1)) + (clambda1 (when (ref-p ref1) (ref-leaf ref1)))) + (when (lambda-p clambda1) + (dolist (var (lambda-vars clambda1) t) + (dolist (var-ref (lambda-var-refs var)) + (let ((dest (lvar-dest (ref-lvar var-ref)))) + (unless (and (combination-p dest) (recurse dest)) + (return-from combination-args-flow-cleanly-p nil))))))))))) + (recurse combination1))) + +(defun trivial-lambda-var-ref-p (use) + (and (ref-p use) + (let ((var (ref-leaf use))) + ;; lambda-var, no SETS + (when (and (lambda-var-p var) (not (lambda-var-sets var))) + (let ((home (lambda-var-home var)) + (refs (lambda-var-refs var))) + ;; bound by a system lambda, no other REFS + (when (and (lambda-system-lambda-p home) + (eq use (car refs)) (not (cdr refs))) + ;; the LAMBDA this var is bound by has only a single REF, going + ;; to a combination + (let* ((lambda-refs (lambda-refs home)) + (primary (car lambda-refs))) + (and (ref-p primary) + (not (cdr lambda-refs)) + (combination-p (lvar-dest (ref-lvar primary))))))))))) + +(defun trivial-lambda-var-ref-lvar (use) + (let* ((this (ref-leaf use)) + (home (lambda-var-home this))) + (multiple-value-bind (fun vars) + (values home (lambda-vars home)) + (let* ((combination (lvar-dest (ref-lvar (car (lambda-refs fun))))) + (args (combination-args combination))) + (assert (= (length vars) (length args))) + (loop for var in vars + for arg in args + when (eq var this) + return arg))))) + +(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) (node-block (lambda-bind clambda))) @@ -361,25 +546,25 @@ ;; 1. It can fail in a few cases even when a meaningful home ;; lambda exists, e.g. in IR1-CONVERT of one of the legs of ;; an IF. - ;; 2. It can fail when converting a form which is born orphaned + ;; 2. It can fail when converting a form which is born orphaned ;; so that it never had a meaningful home lambda, e.g. a form ;; which follows a RETURN-FROM or GO form. (let ((pred-list (block-pred block))) - ;; To deal with case 1, we reason that - ;; previous-in-target-execution-order blocks should be in the - ;; same lambda, and that they seem in practice to be - ;; previous-in-compilation-order blocks too, so we look back - ;; to find one which is sufficiently initialized to tell us - ;; what the home lambda is. - (if pred-list - ;; We could get fancy about this, flooding through the - ;; graph of all the previous blocks, but in practice it - ;; seems to work just to grab the first previous block and - ;; use it. - (node-home-lambda (block-last (first pred-list))) - ;; In case 2, we end up with an empty PRED-LIST and - ;; have to punt: There's no home lambda. - nil)))) + ;; To deal with case 1, we reason that + ;; previous-in-target-execution-order blocks should be in the + ;; same lambda, and that they seem in practice to be + ;; previous-in-compilation-order blocks too, so we look back + ;; to find one which is sufficiently initialized to tell us + ;; what the home lambda is. + (if pred-list + ;; We could get fancy about this, flooding through the + ;; graph of all the previous blocks, but in practice it + ;; seems to work just to grab the first previous block and + ;; use it. + (node-home-lambda (block-last (first pred-list))) + ;; In case 2, we end up with an empty PRED-LIST and + ;; have to punt: There's no home lambda. + nil)))) ;;; Return the non-LET LAMBDA that holds BLOCK's code. (declaim (ftype (sfunction (cblock) clambda) block-home-lambda)) @@ -420,18 +605,18 @@ (defun node-source-form (node) (declare (type node node)) (let* ((path (node-source-path node)) - (forms (source-path-forms path))) + (forms (source-path-forms path))) (if forms - (first forms) - (values (find-original-source path))))) + (first forms) + (values (find-original-source path))))) ;;; 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)))) + (values nil nil) + (values (node-source-form use) t)))) ;;; Return the unique node, delivering a value to LVAR. #!-sb-fluid (declaim (inline lvar-use)) @@ -456,17 +641,21 @@ ;; approach fails, and furthermore realize that in some exceptional ;; cases it might return NIL. -- WHN 2001-12-04 (cond ((ctran-use ctran) - (node-home-lambda (ctran-use ctran))) - ((ctran-block ctran) - (block-home-lambda-or-null (ctran-block ctran))) - (t - (bug "confused about home lambda for ~S" ctran)))) + (node-home-lambda (ctran-use ctran))) + ((ctran-block ctran) + (block-home-lambda-or-null (ctran-block ctran))) + (t + (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) @@ -479,7 +668,7 @@ (cast (locally (declare (notinline lvar-single-value-p)) - (and (not (values-type-p (cast-asserted-type dest))) + (and (cast-single-value-p dest) (lvar-single-value-p (node-lvar dest))))) (t t))))) @@ -503,23 +692,27 @@ ;;; 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 + funs vars blocks tags type-restrictions - (lambda (lexenv-lambda default)) - (cleanup (lexenv-cleanup default)) - (policy (lexenv-policy default))) + (lambda (lexenv-lambda default)) + (cleanup (lexenv-cleanup default)) + (handled-conditions (lexenv-handled-conditions default)) + (disabled-package-locks + (lexenv-disabled-package-locks default)) + (policy (lexenv-policy default))) (macrolet ((frob (var slot) - `(let ((old (,slot default))) - (if ,var - (nconc ,var old) - old)))) + `(let ((old (,slot default))) + (if ,var + (nconc ,var old) + old)))) (internal-make-lexenv (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))) + lambda cleanup handled-conditions + disabled-package-locks policy))) ;;; Makes a LEXENV, suitable for using in a MACROLET introduced ;;; macroexpander @@ -536,7 +729,10 @@ (destructuring-bind (name . thing) var (declare (ignore name)) (etypecase thing - (leaf nil) + ;; The evaluator will mark lexicals with :BOGUS when it + ;; translates an interpreter lexenv to a compiler + ;; lexenv. + ((or leaf #!+sb-eval (member :bogus)) nil) (cons (aver (eq (car thing) 'macro)) t) (heap-alien-info nil))))) @@ -548,6 +744,8 @@ (lexenv-type-restrictions lexenv) ; XXX nil nil + (lexenv-handled-conditions lexenv) + (lexenv-disabled-package-locks lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -556,9 +754,9 @@ (defun link-blocks (block1 block2) (declare (type cblock block1 block2)) (setf (block-succ block1) - (if (block-succ block1) - (%link-blocks block1 block2) - (list block2))) + (if (block-succ block1) + (%link-blocks block1 block2) + (list block2))) (push block1 (block-pred block2)) (values)) (defun %link-blocks (block1 block2) @@ -575,19 +773,19 @@ (declare (type cblock block1 block2)) (let ((succ1 (block-succ block1))) (if (eq block2 (car succ1)) - (setf (block-succ block1) (cdr succ1)) - (do ((succ (cdr succ1) (cdr succ)) - (prev succ1 succ)) - ((eq (car succ) block2) - (setf (cdr prev) (cdr succ))) - (aver succ)))) + (setf (block-succ block1) (cdr succ1)) + (do ((succ (cdr succ1) (cdr succ)) + (prev succ1 succ)) + ((eq (car succ) block2) + (setf (cdr prev) (cdr succ))) + (aver succ)))) (let ((new-pred (delq block1 (block-pred block2)))) (setf (block-pred block2) 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))))) + (when (if-p (block-last pred-block)) + (setf (block-test-modified pred-block) t))))) (values)) ;;; Swing the succ/pred link between BLOCK and OLD to be between BLOCK @@ -599,29 +797,29 @@ (declare (type cblock new old block)) (unlink-blocks block old) (let ((last (block-last block)) - (comp (block-component block))) + (comp (block-component block))) (setf (component-reanalyze comp) t) (typecase last (cif (setf (block-test-modified block) t) (let* ((succ-left (block-succ block)) - (new (if (and (eq new (component-tail comp)) - succ-left) - (first succ-left) - new))) - (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) + (new (if (and (eq new (component-tail comp)) + succ-left) + (first succ-left) + new))) + (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) (when (eq (if-consequent last) (if-alternative last)) - (setf (component-reoptimize (block-component block)) t))))) + (reoptimize-component (block-component block) :maybe))))) (t (unless (memq new (block-succ block)) - (link-blocks block new))))) + (link-blocks block new))))) (values)) @@ -630,7 +828,7 @@ (declaim (ftype (sfunction (cblock) (values)) remove-from-dfo)) (defun remove-from-dfo (block) (let ((next (block-next block)) - (prev (block-prev block))) + (prev (block-prev block))) (setf (block-component block) nil) (setf (block-next prev) next) (setf (block-prev next) prev)) @@ -641,7 +839,7 @@ (defun add-to-dfo (block after) (declare (type cblock block after)) (let ((next (block-next after)) - (comp (block-component after))) + (comp (block-component after))) (aver (not (eq (component-kind comp) :deleted))) (setf (block-component block) comp) (setf (block-next after) block) @@ -650,12 +848,39 @@ (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 &optional dx-cleanup-fun) + (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 = (exit-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))) + ((:dynamic-extent) + (when dx-cleanup-fun + (funcall dx-cleanup-fun cleanup))))))) + ;;; Set the FLAG for all the blocks in COMPONENT to NIL, except for ;;; the head and tail which are set to T. (declaim (ftype (sfunction (component) (values)) clear-flags)) (defun clear-flags (component) (let ((head (component-head component)) - (tail (component-tail component))) + (tail (component-tail component))) (setf (block-flag head) t) (setf (block-flag tail) t) (do-blocks (block component) @@ -667,8 +892,8 @@ (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 tail))) + (tail (make-block-key :start nil :component nil)) + (res (make-component head tail))) (setf (block-flag head) t) (setf (block-flag tail) t) (setf (block-component head) res) @@ -682,34 +907,35 @@ (defun node-ends-block (node) (declare (type node node)) (let* ((block (node-block node)) - (start (node-next node)) - (last (block-last block))) + (start (node-next node)) + (last (block-last block))) + (check-type last node) (unless (eq last node) (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) - :succ succ :last last))) - (setf (ctran-kind start) :block-start) + (new-block + (make-block-key :start start + :component (block-component block) + :succ succ :last last))) + (setf (ctran-kind start) :block-start) (setf (ctran-use start) nil) - (setf (block-last block) node) + (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) ()) - (link-blocks block new-block) - (add-to-dfo new-block block) - (setf (component-reanalyze (block-component block)) t) - - (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)))) + (dolist (b succ) + (setf (block-pred b) + (cons new-block (remove block (block-pred b))))) + (setf (block-succ block) ()) + (link-blocks block new-block) + (add-to-dfo new-block block) + (setf (component-reanalyze (block-component block)) t) + + (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 @@ -723,18 +949,18 @@ ;; 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)))) + (n (position leaf (lambda-vars fun)))) (dolist (ref (leaf-refs fun)) (let* ((lvar (node-lvar ref)) - (dest (and lvar (lvar-dest lvar)))) - (when (and (combination-p dest) - (eq (basic-combination-fun dest) lvar) - (eq (basic-combination-kind dest) :local)) - (let* ((args (basic-combination-args dest)) - (arg (elt args n))) - (reoptimize-lvar arg) - (flush-dest arg) - (setf (elt args n) nil)))))) + (dest (and lvar (lvar-dest lvar)))) + (when (and (combination-p dest) + (eq (basic-combination-fun dest) lvar) + (eq (basic-combination-kind dest) :local)) + (let* ((args (basic-combination-args dest)) + (arg (elt args n))) + (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 @@ -753,13 +979,13 @@ ;; 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)) + (leaf-refs var)) (do ((args (basic-combination-args - (lvar-dest (node-lvar (first (leaf-refs fun))))) - (cdr args)) - (vars (lambda-vars fun) (cdr vars))) - ((eq (car vars) var) - (reoptimize-lvar (car args)))))) + (lvar-dest (node-lvar (first (leaf-refs fun))))) + (cdr args)) + (vars (lambda-vars fun) (cdr vars))) + ((eq (car vars) var) + (reoptimize-lvar (car args)))))) (values)) ;;; Delete a function that has no references. This need only be called @@ -767,78 +993,95 @@ ;;; DELETE-REF will handle the deletion. (defun delete-functional (fun) (aver (and (null (leaf-refs fun)) - (not (functional-entry-fun fun)))) + (not (functional-entry-fun fun)))) (etypecase fun (optional-dispatch (delete-optional-dispatch fun)) (clambda (delete-lambda fun))) (values)) -;;; 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 -;;; CLAMBDA. +;;; 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 :optional :toplevel)))) + (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) - (dolist (let (lambda-lets clambda)) - (setf (lambda-bind let) nil) - (setf (functional-kind let) :deleted)) - ;; 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)))) + (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.) - (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 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) - (delete clambda (component-lambdas component))))) + (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))))) + (setf (functional-entry-fun fun) nil) + (when (optional-dispatch-p fun) + (delete-optional-dispatch fun))))) (values)) @@ -868,61 +1111,83 @@ (setf (functional-kind leaf) :deleted) (flet ((frob (fun) - (unless (eq (functional-kind fun) :deleted) - (aver (eq (functional-kind fun) :optional)) - (setf (functional-kind fun) nil) - (let ((refs (leaf-refs fun))) - (cond ((null refs) - (delete-lambda fun)) - ((null (rest refs)) - (or (maybe-let-convert fun) - (maybe-convert-to-assignment fun))) - (t - (maybe-convert-to-assignment fun))))))) - - (dolist (ep (optional-dispatch-entry-points leaf)) + (unless (eq (functional-kind fun) :deleted) + (aver (eq (functional-kind fun) :optional)) + (setf (functional-kind fun) nil) + (let ((refs (leaf-refs fun))) + (cond ((null refs) + (delete-lambda fun)) + ((null (rest refs)) + (or (maybe-let-convert fun) + (maybe-convert-to-assignment fun))) + (t + (maybe-convert-to-assignment fun))))))) + + (dolist (ep (optional-dispatch-entry-points leaf)) (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))) - (when (eq (functional-kind main) :optional) - (frob main)))))) + (when (optional-dispatch-more-entry leaf) + (frob (optional-dispatch-more-entry leaf))) + (let ((main (optional-dispatch-main-entry leaf))) + (when entry + (setf (functional-entry-fun entry) main) + (setf (functional-entry-fun main) entry)) + (when (eq (functional-kind main) :optional) + (frob main)))))) (values)) +(defun note-local-functional (fun) + (declare (type functional fun)) + (when (and (leaf-has-source-name-p fun) + (eq (leaf-source-name fun) (functional-debug-name fun))) + (let ((name (leaf-source-name fun))) + (let ((defined-fun (gethash name *free-funs*))) + (when (and defined-fun + (defined-fun-p defined-fun) + (eq (defined-fun-functional defined-fun) fun)) + (remhash name *free-funs*)))))) + +;;; Return functional for DEFINED-FUN which has been converted in policy +;;; corresponding to the current one, or NIL if no such functional exists. +(defun defined-fun-functional (defined-fun) + (let ((policy (lexenv-%policy *lexenv*))) + (dolist (functional (defined-fun-functionals defined-fun)) + (when (equal policy (lexenv-%policy (functional-lexenv functional))) + (return functional))))) + ;;; Do stuff to delete the semantic attachments of a REF node. When ;;; this leaves zero or one reference, we do a type dispatch off of ;;; the leaf to determine if a special action is appropriate. (defun delete-ref (ref) (declare (type ref ref)) (let* ((leaf (ref-leaf ref)) - (refs (delq ref (leaf-refs leaf)))) + (refs (delq ref (leaf-refs leaf)))) (setf (leaf-refs leaf) refs) (cond ((null refs) - (typecase leaf - (lambda-var - (delete-lambda-var leaf)) - (clambda - (ecase (functional-kind leaf) - ((nil :let :mv-let :assignment :escape :cleanup) - (aver (null (functional-entry-fun leaf))) - (delete-lambda leaf)) - (:external - (delete-lambda leaf)) - ((:deleted :optional)))) - (optional-dispatch - (unless (eq (functional-kind leaf) :deleted) - (delete-optional-dispatch leaf))))) - ((null (rest refs)) - (typecase leaf - (clambda (or (maybe-let-convert leaf) - (maybe-convert-to-assignment leaf))) - (lambda-var (reoptimize-lambda-var leaf)))) - (t - (typecase leaf - (clambda (maybe-convert-to-assignment leaf)))))) + (typecase leaf + (lambda-var + (delete-lambda-var leaf)) + (clambda + (ecase (functional-kind leaf) + ((nil :let :mv-let :assignment :escape :cleanup) + (aver (null (functional-entry-fun leaf))) + (delete-lambda leaf)) + (:external + (delete-lambda leaf)) + ((:deleted :zombie :optional)))) + (optional-dispatch + (unless (eq (functional-kind leaf) :deleted) + (delete-optional-dispatch leaf))))) + ((null (rest refs)) + (typecase leaf + (clambda (or (maybe-let-convert leaf) + (maybe-convert-to-assignment leaf))) + (lambda-var (reoptimize-lambda-var leaf)))) + (t + (typecase leaf + (clambda (maybe-convert-to-assignment leaf)))))) (values)) @@ -937,9 +1202,10 @@ (flush-lvar-externally-checkable-type lvar) (do-uses (use lvar) (let ((prev (node-prev use))) - (let ((block (ctran-block prev))) - (setf (component-reoptimize (block-component block)) t) - (setf (block-attributep (block-flags block) flush-p type-asserted) + (let ((block (ctran-block prev))) + (reoptimize-component (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)) @@ -953,6 +1219,13 @@ (unless (block-delete-p block) (mark-for-deletion block)))))) +;;; 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) @@ -960,7 +1233,7 @@ (let* ((component (block-component block)) (head (component-head component))) (labels ((helper (block) - (setf (block-delete-p block) t) + (delete-block-lazily block) (dolist (pred (block-pred block)) (unless (or (block-delete-p pred) (eq pred head)) @@ -973,10 +1246,12 @@ ;;; 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. +;;; 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! + #!+high-security (aver (not (memq block (component-delete-blocks (block-component block))))) (unless silent (note-block-deletion block)) (setf (block-delete-p block) t) @@ -996,7 +1271,7 @@ (do-nodes-carefully (node block) (when (valued-node-p node) (delete-lvar-use node)) - (typecase node + (etypecase node (ref (delete-ref node)) (cif (flush-dest (if-test node))) ;; The next two cases serve to maintain the invariant that a LET @@ -1029,6 +1304,11 @@ (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)) @@ -1061,14 +1341,20 @@ (declare (type clambda fun)) (dolist (var (lambda-vars fun)) (unless (or (leaf-ever-used var) - (lambda-var-ignorep var)) + (lambda-var-ignorep var)) (let ((*compiler-error-context* (lambda-bind fun))) - (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. - (compiler-style-warn "The variable ~S is defined but never used." - (leaf-debug-name var))) - (setf (leaf-ever-used var) t)))) ; to avoid repeated warnings? -- WHN + (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)) + ;; There's no reason to accept this kind of equivocation + ;; when compiling our own code, though. + #+sb-xc-host + (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)) (defvar *deletion-ignored-objects* '(t nil)) @@ -1081,22 +1367,22 @@ (defun present-in-form (obj form depth) (declare (type (integer 0 20) depth)) (cond ((= depth 20) nil) - ((eq obj form) t) - ((atom form) nil) - (t - (let ((first (car form)) - (depth (1+ depth))) - (if (member first '(quote function)) - nil - (or (and (not (symbolp first)) - (present-in-form obj first depth)) - (do ((l (cdr form) (cdr l)) - (n 0 (1+ n))) - ((or (atom l) (> n 100)) - nil) - (declare (fixnum n)) - (when (present-in-form obj (car l) depth) - (return t))))))))) + ((eq obj form) t) + ((atom form) nil) + (t + (let ((first (car form)) + (depth (1+ depth))) + (if (member first '(quote function)) + nil + (or (and (not (symbolp first)) + (present-in-form obj first depth)) + (do ((l (cdr form) (cdr l)) + (n 0 (1+ n))) + ((or (atom l) (> n 100)) + nil) + (declare (fixnum n)) + (when (present-in-form obj (car l) depth) + (return t))))))))) ;;; This function is called on a block immediately before we delete ;;; it. We check to see whether any of the code about to die appeared @@ -1120,27 +1406,27 @@ (let ((home (block-home-lambda block))) (unless (eq (functional-kind home) :deleted) (do-nodes (node nil block) - (let* ((path (node-source-path node)) - (first (first path))) - (when (or (eq first 'original-source-start) - (and (atom first) - (or (not (symbolp first)) - (let ((pkg (symbol-package first))) - (and pkg - (not (eq pkg (symbol-package :end)))))) - (not (member first *deletion-ignored-objects*)) - (not (typep first '(or fixnum character))) - (every (lambda (x) - (present-in-form first x 0)) - (source-path-forms path)) - (present-in-form first (find-original-source path) - 0))) - (unless (return-p node) - (let ((*compiler-error-context* node)) - (compiler-notify 'code-deletion-note - :format-control "deleting unreachable code" - :format-arguments nil))) - (return)))))) + (let* ((path (node-source-path node)) + (first (first path))) + (when (or (eq first 'original-source-start) + (and (atom first) + (or (not (symbolp first)) + (let ((pkg (symbol-package first))) + (and pkg + (not (eq pkg (symbol-package :end)))))) + (not (member first *deletion-ignored-objects*)) + (not (typep first '(or fixnum character))) + (every (lambda (x) + (present-in-form first x 0)) + (source-path-forms path)) + (present-in-form first (find-original-source path) + 0))) + (unless (return-p node) + (let ((*compiler-error-context* node)) + (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 @@ -1159,63 +1445,73 @@ (delete-lvar-use node)) (let* ((ctran (node-next node)) - (next (and ctran (ctran-next ctran))) - (prev (node-prev node)) - (block (ctran-block prev)) - (prev-kind (ctran-kind prev)) - (last (block-last block))) + (next (and ctran (ctran-next ctran))) + (prev (node-prev node)) + (block (ctran-block prev)) + (prev-kind (ctran-kind prev)) + (last (block-last block))) (setf (block-type-asserted block) t) (setf (block-test-modified block) t) (cond ((or (eq prev-kind :inside-block) - (and (eq prev-kind :block-start) - (not (eq node last)))) - (cond ((eq node last) - (setf (block-last block) (ctran-use prev)) - (setf (node-next (ctran-use prev)) nil)) - (t - (setf (ctran-next prev) next) - (setf (node-prev next) prev) + (and (eq prev-kind :block-start) + (not (eq node last)))) + (cond ((eq node last) + (setf (block-last block) (ctran-use prev)) + (setf (node-next (ctran-use prev)) nil)) + (t + (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 - (aver (eq prev-kind :block-start)) - (aver (eq node last)) - (let* ((succ (block-succ block)) - (next (first succ))) - (aver (singleton-p succ)) - (cond - ((eq block (first succ)) - (with-ir1-environment-from-node node - (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) - (t - (aver (eq (block-start-cleanup block) - (block-end-cleanup block))) - (unlink-blocks block next) - (dolist (pred (block-pred block)) - (change-block-successor pred block next)) - (remove-from-dfo block) + (setf (node-prev node) nil) + nil) + (t + (aver (eq prev-kind :block-start)) + (aver (eq node last)) + (let* ((succ (block-succ block)) + (next (first succ))) + (aver (singleton-p succ)) + (cond + ((eq block (first succ)) + (with-ir1-environment-from-node node + (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) + (t + (aver (eq (block-start-cleanup block) + (block-end-cleanup block))) + (unlink-blocks block next) + (dolist (pred (block-pred block)) + (change-block-successor pred block next)) + (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))))))) + (setf (node-prev node) nil) + t))))))) + +;;; Return true if CTRAN has been deleted, false if it is still a valid +;;; part of IR1. +(defun ctran-deleted-p (ctran) + (declare (type ctran ctran)) + (let ((block (ctran-block ctran))) + (or (not (block-component block)) + (block-delete-p block)))) ;;; Return true if NODE has been deleted, false if it is still a valid ;;; part of IR1. (defun node-deleted (node) (declare (type node node)) (let ((prev (node-prev node))) - (not (and prev - (let ((block (ctran-block prev))) - (and (block-component block) - (not (block-delete-p block)))))))) + (or (not prev) + (ctran-deleted-p prev)))) ;;; Delete all the blocks and functions in COMPONENT. We scan first ;;; marking the blocks as DELETE-P to prevent weird stuff from being @@ -1225,16 +1521,27 @@ (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 @@ -1245,42 +1552,92 @@ ;;; 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 (lvar fun num-args) +(defun splice-fun-args (lvar fun num-args) #!+sb-doc - "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." + "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. If FUN +is :ANY, the function name is not checked." (declare (type lvar lvar) - (type symbol fun) - (type index num-args)) + (type symbol fun) + (type index num-args)) (let ((outside (lvar-dest lvar)) - (inside (lvar-uses 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 (lvar-fun-name inside-fun) fun) - (give-up-ir1-transform)) + (unless (or (eq fun :any) + (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 lvar outside-args)) - (before-args (subseq outside-args 0 arg-position)) - (after-args (subseq outside-args (1+ arg-position)))) - (dolist (arg inside-args) - (setf (lvar-dest arg) outside) + (unless (= (length inside-args) num-args) + (give-up-ir1-transform)) + (let* ((outside-args (combination-args outside)) + (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 (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 (lvar-uses inside-fun) - (find-free-fun 'list "???")) - (setf (combination-kind inside) - (info :function :info 'list)) - (setf (node-derived-type inside) *wild-type*) - (flush-dest lvar) - (values)))))) + (setf (combination-args inside) nil) + (setf (combination-args outside) + (append before-args inside-args after-args)) + (change-ref-leaf (lvar-uses inside-fun) + (find-free-fun 'list "???")) + (setf (combination-fun-info inside) (info :function :info 'list) + (combination-kind inside) :known) + (setf (node-derived-type inside) *wild-type*) + (flush-dest lvar) + inside-args))))) + +;;; Eliminate keyword arguments from the call (leaving the +;;; parameters in place. +;;; +;;; (FOO ... :BAR X :QUUX Y) +;;; becomes +;;; (FOO ... X Y) +;;; +;;; SPECS is a list of (:KEYWORD PARAMETER) specifications. +;;; Returns the list of specified parameters names in the +;;; order they appeared in the call. N-POSITIONAL is the +;;; number of positional arguments in th call. +(defun eliminate-keyword-args (call n-positional specs) + (let* ((specs (copy-tree specs)) + (all (combination-args call)) + (new-args (reverse (subseq all 0 n-positional))) + (key-args (subseq all n-positional)) + (parameters nil)) + (loop while key-args + do (let* ((key (pop key-args)) + (val (pop key-args)) + (keyword (if (constant-lvar-p key) + (lvar-value key) + (give-up-ir1-transform))) + (spec (or (assoc keyword specs :test #'eq) + (give-up-ir1-transform)))) + (push val new-args) + (flush-dest key) + (push (second spec) parameters) + ;; In case of duplicate keys. + (setf (second spec) (gensym)))) + (setf (combination-args call) (reverse new-args)) + (reverse parameters))) + +(defun extract-fun-args (lvar fun num-args) + (declare (type lvar lvar) + (type (or symbol list) fun) + (type index num-args)) + (let ((fun (if (listp fun) fun (list fun)))) + (let ((inside (lvar-uses lvar))) + (unless (combination-p inside) + (give-up-ir1-transform)) + (let ((inside-fun (combination-fun inside))) + (unless (member (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)) + (values (lvar-fun-name inside-fun) inside-args)))))) (defun flush-combination (combination) (declare (type combination combination)) @@ -1308,8 +1665,8 @@ (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))) + (setf (node-derived-type ref) vltype) + (derive-node-type ref vltype))) (reoptimize-lvar (node-lvar ref))) (values)) @@ -1331,22 +1688,71 @@ ;;; Return a LEAF which represents the specified constant object. If ;;; the object is not in *CONSTANTS*, then we create a new constant -;;; LEAF and enter it. -(defun find-constant (object) - (if (typep object - ;; FIXME: What is the significance of this test? ("things - ;; that are worth uniquifying"?) - '(or symbol number character instance)) - (or (gethash object *constants*) - (setf (gethash object *constants*) - (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) - (make-constant :value object - :%source-name '.anonymous. - :type (ctype-of object) - :where-from :defined))) +;;; LEAF and enter it. If we are producing a fasl file, make sure that +;;; MAKE-LOAD-FORM gets used on any parts of the constant that it +;;; needs to be. +;;; +;;; We are allowed to coalesce things like EQUAL strings and bit-vectors +;;; when file-compiling, but not when using COMPILE. +(defun find-constant (object &optional (name nil namep)) + (let ((faslp (producing-fasl-file))) + (labels ((make-it () + (when faslp + (if namep + (maybe-emit-make-load-forms object name) + (maybe-emit-make-load-forms object))) + (make-constant object)) + (core-coalesce-p (x) + ;; True for things which retain their identity under EQUAL, + ;; so we can safely share the same CONSTANT leaf between + ;; multiple references. + (or (typep x '(or symbol number character)) + ;; Amusingly enough, we see CLAMBDAs --among other things-- + ;; here, from compiling things like %ALLOCATE-CLOSUREs forms. + ;; No point in stuffing them in the hash-table. + (and (typep x 'instance) + (not (or (leaf-p x) (node-p x)))))) + (file-coalesce-p (x) + ;; CLHS 3.2.4.2.2: We are also allowed to coalesce various + ;; other things when file-compiling. + (or (core-coalesce-p x) + (if (consp x) + (if (eq +code-coverage-unmarked+ (cdr x)) + ;; These are already coalesced, and the CAR should + ;; always be OK, so no need to check. + t + (unless (maybe-cyclic-p x) ; safe for EQUAL? + (do ((y x (cdr y))) + ((atom y) (file-coalesce-p y)) + (unless (file-coalesce-p (car y)) + (return nil))))) + ;; We *could* coalesce base-strings as well, + ;; but we'd need a separate hash-table for + ;; that, since we are not allowed to coalesce + ;; base-strings with non-base-strings. + (typep x + '(or bit-vector + ;; in the cross-compiler, we coalesce + ;; all strings with the same contents, + ;; because we will end up dumping them + ;; as base-strings anyway. In the + ;; real compiler, we're not allowed to + ;; coalesce regardless of string + ;; specialized element type, so we + ;; KLUDGE by coalescing only character + ;; strings (the common case) and + ;; punting on the other types. + #+sb-xc-host + string + #-sb-xc-host + (vector character)))))) + (coalescep (x) + (if faslp (file-coalesce-p x) (core-coalesce-p x)))) + (if (and (boundp '*constants*) (coalescep object)) + (or (gethash object *constants*) + (setf (gethash object *constants*) + (make-it))) + (make-it))))) ;;; 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 @@ -1360,7 +1766,7 @@ (flet ((frob (l) (find home l :key #'node-home-lambda - :test-not #'eq))) + :test #'neq))) (or (frob (leaf-refs var)) (frob (basic-var-sets var))))))))) @@ -1369,10 +1775,16 @@ (defun find-nlx-info (exit) (declare (type exit exit)) (let* ((entry (exit-entry exit)) - (entry-cleanup (entry-cleanup entry))) + (cleanup (entry-cleanup entry)) + (block (first (block-succ (node-block exit))))) (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) - (when (eq (nlx-info-exit nlx) exit) - (return nlx))))) + (when (and (eq (nlx-info-block nlx) block) + (eq (nlx-info-cleanup nlx) cleanup)) + (return nlx))))) + +(defun nlx-info-lvar (nlx) + (declare (type nlx-info nlx)) + (node-lvar (block-last (nlx-info-target nlx)))) ;;;; functional hackery @@ -1391,17 +1803,17 @@ (defun looks-like-an-mv-bind (functional) (and (optional-dispatch-p functional) (do ((arg (optional-dispatch-arglist functional) (cdr arg))) - ((null arg) nil) - (let ((info (lambda-var-arg-info (car arg)))) - (unless info (return nil)) - (case (arg-info-kind info) - (:optional - (when (or (arg-info-supplied-p info) (arg-info-default info)) - (return nil))) - (:rest - (return (and (null (cdr arg)) (null (leaf-refs (car arg)))))) - (t - (return nil))))))) + ((null arg) nil) + (let ((info (lambda-var-arg-info (car arg)))) + (unless info (return nil)) + (case (arg-info-kind info) + (:optional + (when (or (arg-info-supplied-p info) (arg-info-default info)) + (return nil))) + (:rest + (return (and (null (cdr arg)) (null (leaf-refs (car arg)))))) + (t + (return nil))))))) ;;; Return true if function is an external entry point. This is true ;;; of normal XEPs (:EXTERNAL kind) and also of top level lambdas @@ -1417,15 +1829,24 @@ (declare (type lvar lvar)) (let ((use (lvar-uses lvar))) (if (ref-p use) - (let ((leaf (ref-leaf use))) - (if (and (global-var-p leaf) - (eq (global-var-kind leaf) :global-function) - (or (not (defined-fun-p leaf)) - (not (eq (defined-fun-inlinep leaf) :notinline)) - notinline-ok)) - (leaf-source-name leaf) - nil)) - nil))) + (let ((leaf (ref-leaf use))) + (if (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (or (not (defined-fun-p leaf)) + (not (eq (defined-fun-inlinep leaf) :notinline)) + notinline-ok)) + (leaf-source-name leaf) + nil)) + nil))) + +(defun lvar-fun-debug-name (lvar) + (declare (type lvar lvar)) + (let ((uses (lvar-uses lvar))) + (flet ((name1 (use) + (leaf-debug-name (ref-leaf use)))) + (if (ref-p uses) + (name1 uses) + (mapcar #'name1 uses))))) ;;; Return the source name of a combination. (This is an idiom ;;; which was used in CMU CL. I gather it always works. -- WHN) @@ -1445,7 +1866,7 @@ (declare (type lambda-var var)) (let ((fun (lambda-var-home var))) (elt (combination-args (let-combination fun)) - (position-or-lose var (lambda-vars fun))))) + (position-or-lose var (lambda-vars fun))))) ;;; Return the LAMBDA that is called by the local CALL. (defun combination-lambda (call) @@ -1462,28 +1883,28 @@ ;;; limit, and warn if so, returning NIL. (defun inline-expansion-ok (node) (let ((expanded (incf (component-inline-expansions - (block-component - (node-block node)))))) + (block-component + (node-block node)))))) (cond ((> expanded *inline-expansion-limit*) nil) - ((= expanded *inline-expansion-limit*) - ;; FIXME: If the objective is to stop the recursive - ;; expansion of inline functions, wouldn't it be more - ;; correct to look back through surrounding expansions - ;; (which are, I think, stored in the *CURRENT-PATH*, and - ;; possibly stored elsewhere too) and suppress expansion - ;; and print this warning when the function being proposed - ;; for inline expansion is found there? (I don't like the - ;; arbitrary numerical limit in principle, and I think - ;; it'll be a nuisance in practice if we ever want the - ;; compiler to be able to use WITH-COMPILATION-UNIT on - ;; arbitrarily huge blocks of code. -- WHN) - (let ((*compiler-error-context* node)) - (compiler-notify "*INLINE-EXPANSION-LIMIT* (~W) was exceeded, ~ - probably trying to~% ~ - inline a recursive function." - *inline-expansion-limit*)) - nil) - (t t)))) + ((= expanded *inline-expansion-limit*) + ;; FIXME: If the objective is to stop the recursive + ;; expansion of inline functions, wouldn't it be more + ;; correct to look back through surrounding expansions + ;; (which are, I think, stored in the *CURRENT-PATH*, and + ;; possibly stored elsewhere too) and suppress expansion + ;; and print this warning when the function being proposed + ;; for inline expansion is found there? (I don't like the + ;; arbitrary numerical limit in principle, and I think + ;; it'll be a nuisance in practice if we ever want the + ;; compiler to be able to use WITH-COMPILATION-UNIT on + ;; arbitrarily huge blocks of code. -- WHN) + (let ((*compiler-error-context* node)) + (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) @@ -1496,8 +1917,22 @@ ;; analysis, it is LET-converted: LET-converted functionals ;; are too badly trashed to expand them inline, and deleted ;; LET-converted functionals are even worse. - (eql (functional-kind functional) :deleted))) + (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 @@ -1508,16 +1943,16 @@ ;;; 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)) + (values list boolean)) + careful-call)) (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)) - (funcall warn-fun "Lisp error during ~A:~%~A" context condition) - (return-from careful-call (values nil nil)))))) + (let ((*compiler-error-context* node)) + (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 @@ -1527,8 +1962,8 @@ `(progn (defun ,careful (specifier) (handler-case (,basic specifier) - (sb!kernel::arg-count-error (condition) - (values nil (list (format nil "~A" condition)))) + (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)))))) @@ -1553,7 +1988,7 @@ ;;; otherwise. The legality and constantness of the keywords should ;;; already have been checked. (declaim (ftype (sfunction (list keyword) (or lvar null)) - find-keyword-lvar)) + find-keyword-lvar)) (defun find-keyword-lvar (args key) (do ((arg args (cddr arg))) ((null arg) nil) @@ -1568,7 +2003,7 @@ (do ((arg args (cddr arg))) ((null arg) t) (unless (and (rest arg) - (constant-lvar-p (first arg))) + (constant-lvar-p (first arg))) (return nil)))) ;;; This function is used by the result of PARSE-DEFTRANSFORM to @@ -1578,9 +2013,9 @@ (defun check-transform-keys (args keys) (and (check-key-args-constant args) (do ((arg args (cddr arg))) - ((null arg) t) - (unless (member (lvar-value (first arg)) keys) - (return nil))))) + ((null arg) t) + (unless (member (lvar-value (first arg)) keys) + (return nil))))) ;;;; miscellaneous @@ -1589,8 +2024,8 @@ (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))) + (policy (or node *lexenv*) + (= inhibit-warnings 0))) (let ((*compiler-error-context* node)) (compiler-notify (event-info-description info)))) @@ -1626,4 +2061,25 @@ (do-uses (node lvar) (setf (node-reoptimize node) t) (setf (block-reoptimize (node-block node)) t) - (setf (component-reoptimize (node-component node)) t))))))) + (reoptimize-component (node-component node) :maybe))))))) + +;;; Return true if LVAR's only use is a non-NOTINLINE reference to a +;;; global function with one of the specified NAMES. +(defun lvar-fun-is (lvar names) + (declare (type lvar lvar) (list names)) + (let ((use (lvar-uses lvar))) + (and (ref-p use) + (let ((leaf (ref-leaf use))) + (and (global-var-p leaf) + (eq (global-var-kind leaf) :global-function) + (not (null (member (leaf-source-name leaf) names + :test #'equal)))))))) + +(defun lvar-matches (lvar &key fun-names arg-count) + (let ((use (lvar-use lvar))) + (and (combination-p use) + (or (not fun-names) + (member (combination-fun-source-name use) + fun-names :test #'eq)) + (or (not arg-count) + (= arg-count (length (combination-args use)))))))