+;;; Call FUN with (arg-lvar arg-type)
+(defun map-combination-args-and-types (fun call)
+ (declare (type function fun) (type combination call))
+ (binding* ((type (lvar-type (combination-fun call)))
+ (nil (fun-type-p type) :exit-if-null)
+ (args (combination-args call)))
+ (dolist (req (fun-type-required type))
+ (when (null args) (return-from map-combination-args-and-types))
+ (let ((arg (pop args)))
+ (funcall fun arg req)))
+ (dolist (opt (fun-type-optional type))
+ (when (null args) (return-from map-combination-args-and-types))
+ (let ((arg (pop args)))
+ (funcall fun arg opt)))
+
+ (let ((rest (fun-type-rest type)))
+ (when rest
+ (dolist (arg args)
+ (funcall fun arg rest))))
+
+ (dolist (key (fun-type-keywords type))
+ (let ((name (key-info-name key)))
+ (do ((arg args (cddr arg)))
+ ((null arg))
+ (when (eq (lvar-value (first arg)) name)
+ (funcall fun (second arg) (key-info-type key))))))))
+
+;;; 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
+;;; keyword positions.
+(defun assert-call-type (call type &optional (trusted t))
+ (declare (type combination call) (type fun-type type))
+ (let ((policy (lexenv-policy (node-lexenv call)))
+ (returns (fun-type-returns type)))
+ (if trusted
+ (derive-node-type call returns)
+ (let ((lvar (node-lvar call)))
+ ;; If the value is used in a non-tail position, and the lvar
+ ;; is a single-use, assert the type. Multiple use sites need
+ ;; to be elided because the assertion has to apply to all
+ ;; uses. Tail positions are elided because the assertion
+ ;; would cause us not the be in a tail-position anymore. MV
+ ;; calls are elided because not only are the assertions of
+ ;; less use there, but they can cause the MV call conversion
+ ;; to cause astray.
+ (when (and lvar
+ (not (return-p (lvar-dest lvar)))
+ (not (mv-combination-p (lvar-dest lvar)))
+ (lvar-has-single-use-p lvar))
+ (when (assert-lvar-type lvar returns policy)
+ (reoptimize-lvar lvar)))))
+ (map-combination-args-and-types
+ (lambda (arg type)
+ (when (assert-lvar-type arg type policy)
+ (unless trusted (reoptimize-lvar arg))))
+ call))
+ (values))
+\f
+;;;; FIXME: Move to some other file.