(setf (node-next (block-last block)) nil)
block))))
\f
-;;;; continuation use hacking
+;;;; lvar use hacking
;;; Return a list of all the nodes which use LVAR.
(declaim (ftype (sfunction (lvar) list) find-uses))
(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))
(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
(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)))
(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))))))
\f
-;;;; 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.
(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)))
(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)
(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))
(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
(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
(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))
(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))
;;; 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)
(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)))
;; 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)))))))))
\f
;;;; careful call
projects / sbcl.git / blobdiff