;;; 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))))
(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))
\f
;;;; block starting/creation
(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)))
;;; Deal with deleting the last reference to a CLAMBDA. It is called
;;; in two situations: when the lambda is unreachable (so that its
-;;; body mey be deleted), and when it is an effectless LET (in this
+;;; 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.
(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
+ (when bind ; CLAMBDA is deleted due to unreachability
(labels ((delete-children (lambda)
(dolist (child (lambda-children lambda))
- (if (eq (functional-kind child) :deleted)
- (delete-children child)
- (delete-lambda child))
- (setf (lambda-children lambda) nil))
+ (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)))
+ (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
(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))
(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)
(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))
;;; 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)
(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))
(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)))))))
(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
;; 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