;;; 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
(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)
(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))
(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))
+ (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