(merge-tail-sets merge)))))
(t (flush-dest value)
(unlink-node node))))
+
+;;; Make a CAST and insert it into IR1 before node NEXT.
+(defun insert-cast-before (next lvar type policy)
+ (declare (type node next) (type lvar lvar) (type ctype type))
+ (with-ir1-environment-from-node next
+ (let* ((ctran (node-prev next))
+ (cast (make-cast lvar type policy))
+ (internal-ctran (make-ctran)))
+ (setf (ctran-next ctran) cast
+ (node-prev cast) ctran)
+ (use-ctran cast internal-ctran)
+ (link-node-to-previous-ctran next internal-ctran)
+ (setf (lvar-dest lvar) cast)
+ (reoptimize-lvar lvar)
+ (when (return-p next)
+ (node-ends-block cast))
+ (setf (block-attributep (block-flags (node-block cast))
+ type-check type-asserted)
+ t)
+ cast)))
\f
;;;; miscellaneous shorthand functions
(frob if-alternative)
(when (eq (if-consequent last)
(if-alternative last))
- (setf (component-reoptimize (block-component block)) t)))))
+ (reoptimize-component (block-component block) :maybe)))))
(t
(unless (memq new (block-succ block))
(link-blocks block new)))))
(when (optional-dispatch-more-entry leaf)
(frob (optional-dispatch-more-entry leaf)))
(let ((main (optional-dispatch-main-entry leaf)))
+ (when entry
+ (setf (functional-entry-fun entry) main)
+ (setf (functional-entry-fun main) entry))
(when (eq (functional-kind main) :optional)
(frob main))))))
(do-uses (use lvar)
(let ((prev (node-prev use)))
(let ((block (ctran-block prev)))
- (setf (component-reoptimize (block-component block)) t)
+ (reoptimize-component (block-component block) t)
(setf (block-attributep (block-flags block)
flush-p type-asserted type-check)
t)))
(setf (node-prev node) nil)
t)))))))
+;;; Return true if CTRAN has been deleted, false if it is still a valid
+;;; part of IR1.
+(defun ctran-deleted-p (ctran)
+ (declare (type ctran ctran))
+ (let ((block (ctran-block ctran)))
+ (or (not (block-component block))
+ (block-delete-p block))))
+
;;; Return true if NODE has been deleted, false if it is still a valid
;;; part of IR1.
(defun node-deleted (node)
(declare (type node node))
(let ((prev (node-prev node)))
- (not (and prev
- (let ((block (ctran-block prev)))
- (and (block-component block)
- (not (block-delete-p block))))))))
+ (or (not prev)
+ (ctran-deleted-p prev))))
;;; Delete all the blocks and functions in COMPONENT. We scan first
;;; marking the blocks as DELETE-P to prevent weird stuff from being
(do-uses (node lvar)
(setf (node-reoptimize node) t)
(setf (block-reoptimize (node-block node)) t)
- (setf (component-reoptimize (node-component node)) t)))))))
+ (reoptimize-component (node-component node) :maybe)))))))