-(defun convert-type-check (cont types)
- (declare (type continuation cont) (type list types))
- (with-ir1-environment-from-node (continuation-dest cont)
-
- ;; Ensuring that CONT starts a block lets us freely manipulate its uses.
- (ensure-block-start cont)
-
- ;; Make a new continuation and move CONT's uses to it.
- (let* ((new-start (make-continuation))
- (dest (continuation-dest cont))
- (prev (node-prev dest)))
- (continuation-starts-block new-start)
- (substitute-continuation-uses new-start cont)
-
- ;; Setting TYPE-CHECK in CONT to :DELETED indicates that the
- ;; check has been done.
- (setf (continuation-%type-check cont) :deleted)
-
- ;; Make the DEST node start its block so that we can splice in
- ;; the type check code.
- (when (continuation-use prev)
- (node-ends-block (continuation-use prev)))
-
- (let* ((prev-block (continuation-block prev))
- (new-block (continuation-block new-start))
- (dummy (make-continuation)))
-
- ;; Splice in the new block before DEST, giving the new block
- ;; all of DEST's predecessors.
- (dolist (block (block-pred prev-block))
- (change-block-successor block prev-block new-block))
-
- ;; Convert the check form, using the new block start as START
- ;; and a dummy continuation as CONT.
- (ir1-convert new-start dummy (make-type-check-form types))
-
- ;; TO DO: Why should this be true? -- WHN 19990601
- (aver (eq (continuation-block dummy) new-block))
-
- ;; 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
-
- (let ((node (continuation-use dummy)))
- (setf (block-last new-block) node)
- ;; Change the use to a use of CONT. (We need to use the
- ;; dummy continuation to get the control transfer right,
- ;; because we want to go to PREV's block, not CONT's.)
- (delete-continuation-use node)
- (add-continuation-use node cont))
- ;; Link the new block to PREV's block.
- (link-blocks new-block prev-block))
-
- ;; MAKE-TYPE-CHECK-FORM generated a form which checked the type
- ;; of 'DUMMY, not a real form. At this point we convert to the
- ;; real form by finding 'DUMMY and overwriting it with the new
- ;; continuation. (We can find 'DUMMY because no LET conversion
- ;; has been done yet.) The [mv-]combination code from the
- ;; mv-bind in the check form will be the use of the new check
- ;; continuation. We substitute for the first argument of this
- ;; node.
- (let* ((node (continuation-use cont))
- (args (basic-combination-args node))
- (victim (first args)))
- (aver (and (= (length args) 1)
- (eq (constant-value
- (ref-leaf
- (continuation-use victim)))
- 'dummy)))
- (substitute-continuation new-start victim)))
-
- ;; Invoking local call analysis converts this call to a LET.
- (locall-analyze-component *current-component*))
+(defun convert-type-check (cast types)
+ (declare (type cast cast) (type list types))
+ (let ((cont (cast-value cast))
+ (length (length types)))
+ (filter-continuation cont (make-type-check-form types))
+ (reoptimize-continuation (cast-value cast))
+ (setf (cast-type-to-check cast) *wild-type*)
+ (setf (cast-%type-check cast) nil)
+ (let* ((atype (cast-asserted-type cast))
+ (atype (cond ((not (values-type-p atype))
+ atype)
+ ((= length 1)
+ (single-value-type atype))
+ (t
+ (make-values-type :required
+ (values-type-start atype length)))))
+ (dtype (node-derived-type cast))
+ (dtype (make-values-type :required
+ (values-type-start dtype length))))
+ (setf (cast-asserted-type cast) atype)
+ (setf (node-derived-type cast) dtype)))
projects / sbcl.git / blobdiff