X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1util.lisp;h=e41c094bb66a4170fe50bab32a5133bf57474dbd;hb=f8893c7c658bf9d9e0757c63e47af2fdea810f04;hp=bca0627ca1c54c1f9191c7785f5cb58683ab14b6;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index bca0627..e41c094 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,14 +68,12 @@ (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)) @@ -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. @@ -328,6 +324,13 @@ (defun node-dest (node) (awhen (node-lvar node) (lvar-dest it))) +;;; Checks whether NODE is in a block to be deleted +(declaim (inline node-to-be-deleted-p)) +(defun node-to-be-deleted-p (node) + (let ((block (node-block node))) + (or (block-delete-p block) + (eq (functional-kind (block-home-lambda block)) :deleted)))) + (declaim (ftype (sfunction (clambda) cblock) lambda-block)) (defun lambda-block (clambda) (node-block (lambda-bind clambda))) @@ -428,8 +431,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) @@ -776,20 +779,31 @@ (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. It is called +;;; in two situations: when the lambda is unreachable (so that its +;;; body may be deleted), and when it is an effectless LET (in this +;;; case its body is reachable and is not completely "its"). 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))) (setf (functional-kind clambda) :deleted) (setf (lambda-bind clambda) nil) + + (when bind ; CLAMBDA is deleted due to unreachability + (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))) (dolist (let (lambda-lets clambda)) (setf (lambda-bind let) nil) (setf (functional-kind let) :deleted)) @@ -832,7 +846,7 @@ (delete clambda (tail-set-funs tails))) (setf (lambda-tail-set clambda) nil)) (setf (component-lambdas component) - (delete clambda (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 @@ -999,7 +1013,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 +1046,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)) @@ -1230,10 +1249,11 @@ (do-blocks (block component) (setf (block-delete-p block) t)) (dolist (fun (component-lambdas component)) - (setf (functional-kind fun) nil) - (setf (functional-entry-fun fun) nil) - (setf (leaf-refs fun) nil) - (delete-functional fun)) + (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))) (do-blocks (block component) (delete-block block)) (values)) @@ -1250,7 +1270,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) @@ -1442,8 +1462,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))) @@ -1501,6 +1521,18 @@ ;; LET-converted functionals are even worse. (eql (functional-kind functional) :deleted))) (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 (fun-info-p kind) + (not (fun-info-ir2-convert kind)) + (dolist (template (fun-info-templates kind) 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