(list uses))))
(defun principal-lvar-use (lvar)
- (let ((use (lvar-uses lvar)))
- (if (cast-p use)
- (principal-lvar-use (cast-value use))
- use)))
+ (labels ((plu (lvar)
+ (declare (type lvar lvar))
+ (let ((use (lvar-uses lvar)))
+ (if (cast-p use)
+ (plu (cast-value use))
+ use))))
+ (plu lvar)))
;;; Update lvar use information so that NODE is no longer a use of its
;;; LVAR.
(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
((:block :tagbody)
(aver (entry-p mess-up))
(loop for exit in (entry-exits mess-up)
- for nlx-info = (find-nlx-info exit)
+ for nlx-info = (exit-nlx-info exit)
do (funcall fun nlx-info)))
((:catch :unwind-protect)
(aver (combination-p mess-up))
(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))))))
;;; exits to CONT in that entry, then return it, otherwise return NIL.
(defun find-nlx-info (exit)
(declare (type exit exit))
- (let ((entry (exit-entry exit)))
+ (let* ((entry (exit-entry exit))
+ (cleanup (entry-cleanup entry))
+ (block (first (block-succ (node-block exit)))))
(dolist (nlx (physenv-nlx-info (node-physenv entry)) nil)
- (when (eq (nlx-info-exit nlx) exit)
+ (when (and (eq (nlx-info-block nlx) block)
+ (eq (nlx-info-cleanup nlx) cleanup))
(return nlx)))))
+
+(defun nlx-info-lvar (nlx)
+ (declare (type nlx-info nlx))
+ (node-lvar (block-last (nlx-info-target nlx))))
\f
;;;; functional hackery