+
+;;; CTRAN must be the last ctran in an incomplete block; finish the
+;;; block and start a new one if necessary.
+(defun start-block (ctran)
+ (declare (type ctran ctran))
+ (aver (not (ctran-next ctran)))
+ (ecase (ctran-kind ctran)
+ (:inside-block
+ (let ((block (ctran-block ctran))
+ (node (ctran-use ctran)))
+ (aver (not (block-last block)))
+ (aver node)
+ (setf (block-last block) node)
+ (setf (node-next node) nil)
+ (setf (ctran-use ctran) nil)
+ (setf (ctran-kind ctran) :unused)
+ (setf (ctran-block ctran) nil)
+ (link-blocks block (ctran-starts-block ctran))))
+ (:block-start)))
+\f
+;;;;
+
+;;; Filter values of LVAR through FORM, which must be an ordinary/mv
+;;; call. First argument must be 'DUMMY, which will be replaced with
+;;; LVAR. In case of an ordinary call the function should not have
+;;; return type NIL. We create a new "filtered" lvar.
+;;;
+;;; TODO: remove preconditions.
+(defun filter-lvar (lvar form)
+ (declare (type lvar lvar) (type list form))
+ (let* ((dest (lvar-dest lvar))
+ (ctran (node-prev dest)))
+ (with-ir1-environment-from-node dest
+
+ (ensure-block-start ctran)
+ (let* ((old-block (ctran-block ctran))
+ (new-start (make-ctran))
+ (filtered-lvar (make-lvar))
+ (new-block (ctran-starts-block new-start)))
+
+ ;; Splice in the new block before DEST, giving the new block
+ ;; all of DEST's predecessors.
+ (dolist (block (block-pred old-block))
+ (change-block-successor block old-block new-block))
+
+ (ir1-convert new-start ctran filtered-lvar form)
+
+ ;; KLUDGE: Comments at the head of this function in CMU CL
+ ;; said that somewhere in here we
+ ;; Set the new block's start and end cleanups to the *start*
+ ;; cleanup of PREV's block. This overrides the incorrect
+ ;; default from WITH-IR1-ENVIRONMENT-FROM-NODE.
+ ;; Unfortunately I can't find any code which corresponds to this.
+ ;; Perhaps it was a stale comment? Or perhaps I just don't
+ ;; understand.. -- WHN 19990521
+
+ ;; Replace 'DUMMY with the LVAR. (We can find 'DUMMY because
+ ;; no LET conversion has been done yet.) The [mv-]combination
+ ;; code from the call in the form will be the use of the new
+ ;; check lvar. We substitute for the first argument of
+ ;; this node.
+ (let* ((node (lvar-use filtered-lvar))
+ (args (basic-combination-args node))
+ (victim (first args)))
+ (aver (eq (constant-value (ref-leaf (lvar-use victim)))
+ 'dummy))
+
+ (substitute-lvar filtered-lvar lvar)
+ (substitute-lvar lvar victim)
+ (flush-dest victim))
+
+ ;; Invoking local call analysis converts this call to a LET.
+ (locall-analyze-component *current-component*))))
+ (values))
+
+;;; Delete NODE and VALUE. It may result in some calls becoming tail.
+(defun delete-filter (node lvar value)
+ (aver (eq (lvar-dest value) node))
+ (aver (eq (node-lvar node) lvar))
+ (cond (lvar (collect ((merges))
+ (when (return-p (lvar-dest lvar))
+ (do-uses (use value)
+ (when (and (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (substitute-lvar-uses lvar value
+ (and lvar (eq (lvar-uses lvar) node)))
+ (%delete-lvar-use node)
+ (prog1
+ (unlink-node node)
+ (dolist (merge (merges))
+ (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)))