X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=7600eebfa19f18128490efac5b63ba4a6378d022;hb=a163c70e2bef35bf482a785dbfd9c545b4fcd555;hp=bca0627ca1c54c1f9191c7785f5cb58683ab14b6;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index bca0627..7600eeb 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -52,7 +52,7 @@ (setf (node-next (block-last block)) nil) block)))) -;;;; continuation use hacking +;;;; lvar use hacking ;;; Return a list of all the nodes which use LVAR. (declaim (ftype (sfunction (lvar) list) find-uses)) @@ -68,21 +68,19 @@ (principal-lvar-use (cast-value use)) use))) -;;; Update continuation use information so that NODE is no longer a -;;; use of its CONT. If the old continuation doesn't start its block, -;;; then we don't update the BLOCK-START-USES, since it will be -;;; deleted when we are done. +;;; 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. +;;; 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))) + (let ((lvar (node-lvar node))) (when lvar (if (listp (lvar-uses lvar)) (let ((new-uses (delq node (lvar-uses lvar)))) @@ -93,7 +91,8 @@ (setf (lvar-uses lvar) nil)) (setf (node-lvar node) nil))) (values)) -;;; Delete NODE from its LVAR uses. +;;; 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 @@ -106,13 +105,11 @@ (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. +;;; 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))) @@ -134,14 +131,13 @@ (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)))))) -;;;; continuation substitution +;;;; lvar substitution ;;; In OLD's DEST, replace OLD with NEW. NEW's DEST must initially be ;;; NIL. We do not flush OLD's DEST. @@ -173,12 +169,11 @@ (declare (type lvar old) (type (or lvar null) new)) - (do-uses (node old) - (%delete-lvar-use node) - (when new - (add-lvar-use node new))) - - (when new (reoptimize-lvar 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 @@ -225,6 +220,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))) ;;;; @@ -310,7 +324,7 @@ (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)))) @@ -328,6 +342,16 @@ (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) (node-block (lambda-bind clambda))) @@ -428,8 +452,8 @@ (first forms) (values (find-original-source path))))) -;;; Return NODE-SOURCE-FORM, T if continuation has a single use, -;;; otherwise NIL, NIL. +;;; 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) @@ -470,6 +494,10 @@ (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) @@ -482,7 +510,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))))) @@ -510,6 +538,9 @@ type-restrictions (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))) @@ -522,7 +553,8 @@ (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 @@ -551,6 +583,8 @@ (lexenv-type-restrictions lexenv) ; XXX nil nil + (lexenv-handled-conditions lexenv) + (lexenv-disabled-package-locks lexenv) (lexenv-policy lexenv)))) ;;;; flow/DFO/component hackery @@ -653,6 +687,30 @@ (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 (sfunction (component) (values)) clear-flags)) @@ -776,63 +834,80 @@ (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)))) + (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 @@ -914,7 +989,7 @@ (delete-lambda leaf)) (:external (delete-lambda leaf)) - ((:deleted :optional)))) + ((:deleted :zombie :optional)))) (optional-dispatch (unless (eq (functional-kind leaf) :deleted) (delete-optional-dispatch leaf))))) @@ -942,7 +1017,8 @@ (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) + (setf (block-attributep (block-flags block) + flush-p type-asserted type-check) t))) (setf (node-lvar use) nil)) (setf (lvar-uses lvar) nil)) @@ -956,6 +1032,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) @@ -963,7 +1046,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)) @@ -976,10 +1059,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) @@ -999,7 +1084,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 @@ -1032,6 +1117,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)) @@ -1069,8 +1159,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 + (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)) @@ -1205,7 +1301,11 @@ (unlink-blocks block next) (dolist (pred (block-pred block)) (change-block-successor pred block next)) - (remove-from-dfo block) + (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))))))) @@ -1228,16 +1328,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 @@ -1250,7 +1361,7 @@ ;;; arguments. (defun extract-fun-args (lvar fun num-args) #!+sb-doc - "If CONT is a call to FUN with NUM-ARGS args, change those arguments + "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) @@ -1279,8 +1390,8 @@ (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 (combination-fun-info inside) (info :function :info 'list) + (combination-kind inside) :known) (setf (node-derived-type inside) *wild-type*) (flush-dest lvar) (values)))))) @@ -1363,7 +1474,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))))))))) @@ -1371,8 +1482,7 @@ ;;; exits to CONT in that entry, then return it, otherwise return NIL. (defun find-nlx-info (exit) (declare (type exit exit)) - (let* ((entry (exit-entry exit)) - (entry-cleanup (entry-cleanup entry))) + (let ((entry (exit-entry exit))) (dolist (nlx (physenv-nlx-info (node-physenv entry)) nil) (when (eq (nlx-info-exit nlx) exit) (return nlx))))) @@ -1442,8 +1552,8 @@ (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))) @@ -1499,8 +1609,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