+
+;;; 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))
+ (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))
+
+ (flet ((delete-cast ()
+ (let ((cont (node-cont cast)))
+ (delete-filter cast cont value)
+ (reoptimize-continuation cont)
+ (when (continuation-single-value-p cont)
+ (note-single-valuified-continuation cont))
+ (when (not (continuation-dest cont))
+ (reoptimize-continuation-uses cont)))))
+ (cond
+ ((and (not do-not-optimize)
+ (values-subtypep value-type
+ (cast-asserted-type cast)))
+ (delete-cast)
+ (return-from ir1-optimize-cast t))
+ ((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)))