-;;; We can always use Multiple-Value-Bind, since the macro is clever about
-;;; binding a single variable.
-(defun make-type-check-form (types)
- (collect ((temps))
- (dotimes (i (length types))
- (temps (gensym)))
-
- `(multiple-value-bind ,(temps)
- 'dummy
- ,@(mapcar #'(lambda (temp type)
- (let* ((spec
- (let ((*unparse-function-type-simplify* t))
- (type-specifier (second type))))
- (test (if (first type) `(not ,spec) spec)))
- `(unless (typep ,temp ',test)
- (%type-check-error
- ,temp
- ',(type-specifier (third type))))))
- (temps) types)
- (values ,@(temps)))))
-
-;;; Splice in explicit type check code immediately before the node which is
-;;; Cont's Dest. This code receives the value(s) that were being passed to
-;;; Cont, checks the type(s) of the value(s), then passes them on to Cont.
-(defun convert-type-check (cont types)
- (declare (type continuation cont) (type list types))
- (with-ir1-environment (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
- (assert (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.
- ;; 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)))
- (assert (and (= (length args) 1)
- (eq (constant-value
- (ref-leaf
- (continuation-use victim)))
- 'dummy)))
- (substitute-continuation new-start victim)))
+;;; The logic used to be more complex, but most of the cases that used
+;;; to be checked here are now dealt with differently . FIXME: but
+;;; here's one we used to do, don't anymore, but could still benefit
+;;; from, if we reimplemented it (elsewhere):
+;;;
+;;; -- If the lvar is an argument to a known function that has
+;;; no IR2-CONVERT method or :FAST-SAFE templates that are
+;;; compatible with the call's type: return NIL.
+;;;
+;;; The code used to look like something like this:
+;;; ...
+;;; (:known
+;;; (let ((info (basic-combination-fun-info dest)))
+;;; (if (fun-info-ir2-convert info)
+;;; t
+;;; (dolist (template (fun-info-templates info) nil)
+;;; (when (eq (template-ltn-policy template)
+;;; :fast-safe)
+;;; (multiple-value-bind (val win)
+;;; (valid-fun-use dest (template-type template))
+;;; (when (or val (not win)) (return t)))))))))))))
+;;;
+;;; ADP says: It is still interesting. When we have a :SAFE template
+;;; and the type assertion is derived from the destination function
+;;; type, the check is unneccessary. We cannot return NIL here (the
+;;; whole function has changed its meaning, and here NIL *forces*
+;;; hairy check), but the functionality is interesting.
+(defun probable-type-check-p (cast)
+ (declare (type cast cast))
+ (let* ((lvar (node-lvar cast))
+ (dest (and lvar (lvar-dest lvar))))
+ (cond ((not dest) nil)
+ (t t))))