+
+;;; TODO:
+;;; - CAST chains;
+(defun ir1-optimize-cast (cast &optional do-not-optimize)
+ (declare (type cast cast))
+ (let* ((value (cast-value cast))
+ (value-type (continuation-derived-type value))
+ (cont (node-cont cast))
+ (dest (continuation-dest cont))
+ (atype (cast-asserted-type cast))
+ (int (values-type-intersection value-type atype)))
+ (derive-node-type cast int)
+ (when (eq int *empty-type*)
+ (unless (eq value-type *empty-type*)
+
+ ;; FIXME: Do it in one step.
+ (filter-continuation
+ value
+ `(multiple-value-call #'list 'dummy))
+ (filter-continuation
+ value
+ ;; FIXME: Derived type.
+ `(%compile-time-type-error 'dummy
+ ',(type-specifier atype)
+ ',(type-specifier value-type)))
+ ;; KLUDGE: FILTER-CONTINUATION does not work for
+ ;; non-returning functions, so we declare the return type of
+ ;; %COMPILE-TIME-TYPE-ERROR to be * and derive the real type
+ ;; here.
+ (derive-node-type (continuation-use value) *empty-type*)
+ (maybe-terminate-block (continuation-use value) nil)
+ ;; FIXME: Is it necessary?
+ (aver (null (block-pred (node-block cast))))
+ (setf (block-delete-p (node-block cast)) t)
+ (return-from ir1-optimize-cast)))
+ (when (eq (node-derived-type cast) *empty-type*)
+ (maybe-terminate-block cast nil))
+
+ (when (and (not do-not-optimize)
+ (values-subtypep value-type
+ (cast-asserted-type cast)))
+ (delete-filter cast cont value)
+ (reoptimize-continuation cont)
+ (when (continuation-single-value-p cont)
+ (note-single-valuified-continuation cont))
+ (when (not dest)
+ (reoptimize-continuation-uses cont))
+ (return-from ir1-optimize-cast t))
+
+ (when (and (not do-not-optimize)
+ (not (continuation-use value))
+ dest)
+ (collect ((merges))
+ (do-uses (use value)
+ (when (and (values-subtypep (node-derived-type use) atype)
+ (immediately-used-p value use))
+ (ensure-block-start cont)
+ (delete-continuation-use use)
+ (add-continuation-use use cont)
+ (unlink-blocks (node-block use) (node-block cast))
+ (link-blocks (node-block use) (continuation-block cont))
+ (when (and (return-p dest)
+ (basic-combination-p use)
+ (eq (basic-combination-kind use) :local))
+ (merges use))))
+ (dolist (use (merges))
+ (merge-tail-sets use))))
+
+ (when (and (cast-%type-check cast)
+ (values-subtypep value-type
+ (cast-type-to-check cast)))
+ (setf (cast-%type-check cast) nil)))
+
+ (unless do-not-optimize
+ (setf (node-reoptimize cast) nil)))