;;; This is similar to DERIVE-NODE-TYPE, but asserts that it is an
;;; error for CONT's value not to be TYPEP to TYPE. We implement it
-;;; moving uses behind a new CAST node. If we improve the assertion,
+;;; splitting off DEST a new CAST node. If we improve the assertion,
;;; we set TYPE-CHECK and TYPE-ASSERTED to guarantee that the new
-;;; assertion will be checked.
+;;; assertion will be checked. We return the new "argument"
+;;; continuation of DEST.
(defun assert-continuation-type (cont type policy)
(declare (type continuation cont) (type ctype type))
- (when (values-subtypep (continuation-derived-type cont) type)
- (return-from assert-continuation-type))
- (let* ((dest (continuation-dest cont))
- (prev-cont (node-prev dest)))
- (aver dest)
- (with-ir1-environment-from-node dest
- (let* ((cast (make-cast cont type policy))
- (checked-value (make-continuation)))
- (setf (continuation-next prev-cont) cast
- (node-prev cast) prev-cont)
- (use-continuation cast checked-value)
- (link-node-to-previous-continuation dest checked-value)
- (substitute-continuation checked-value cont)
- (setf (continuation-dest cont) cast)
- (reoptimize-continuation cont)))))
+ (if (values-subtypep (continuation-derived-type cont) type)
+ cont
+ (let* ((dest (continuation-dest cont))
+ (prev-cont (node-prev dest)))
+ (aver dest)
+ (with-ir1-environment-from-node dest
+ (let* ((cast (make-cast cont type policy))
+ (checked-value (make-continuation)))
+ (setf (continuation-next prev-cont) cast
+ (node-prev cast) prev-cont)
+ (use-continuation cast checked-value)
+ (link-node-to-previous-continuation dest checked-value)
+ (substitute-continuation checked-value cont)
+ (setf (continuation-dest cont) cast)
+ (reoptimize-continuation cont)
+ checked-value)))))
;;; Assert that CALL is to a function of the specified TYPE. It is
;;; assumed that the call is legal and has only constants in the
(join-blocks block next))
t)
((and (null (block-start-uses next))
- (not (exit-p (continuation-dest last-cont)))
+ (not (typep (continuation-dest last-cont)
+ '(or exit creturn)))
(null (continuation-lexenv-uses last-cont)))
(assert (null (find-uses next-cont)))
(when (continuation-dest last-cont)
;; issue a full WARNING if the call
;; violates a DECLAIM FTYPE.
:lossage-fun #'compiler-style-warn
- :unwinnage-fun #'compiler-note)
+ :unwinnage-fun #'compiler-notify)
(assert-call-type call type)
(maybe-terminate-block call ir1-converting-not-optimizing-p)
(recognize-known-call call ir1-converting-not-optimizing-p))
(unless (continuation-single-value-p (node-cont node))
(give-up-ir1-transform))
(setf (node-derived-type node) *wild-type*)
+ (principal-continuation-single-valuify (node-cont node))
(if vals
(let ((dummies (make-gensym-list (length (cdr vals)))))
`(lambda (val ,@dummies)
(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)
value
;; FIXME: Derived type.
`(%compile-time-type-error 'dummy
- ',(type-specifier (coerce-to-values atype))
+ ',(type-specifier atype)
',(type-specifier value-type)))
;; KLUDGE: FILTER-CONTINUATION does not work for
;; non-returning functions, so we declare the return type of
(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)))))
+ (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)))