(unless (optional-dispatch-keyp od)
(frob (not (null (optional-dispatch-more-entry od)))
(not (null (fun-type-rest type)))
- "&REST arguments"))
+ "&REST argument"))
(frob (optional-dispatch-allowp od) (fun-type-allowp type)
"&ALLOW-OTHER-KEYS"))
(type-specifier type))))
(t
(setf (leaf-type var) type)
- (dolist (ref (leaf-refs var))
- (derive-node-type ref (make-single-value-type type))))))
+ (let ((s-type (make-single-value-type type)))
+ (dolist (ref (leaf-refs var))
+ (derive-node-type ref s-type))))))
t))))))
;;; FIXME: This is quite similar to ASSERT-NEW-DEFINITION.
(let ((type (info :function :type name))
(where (info :function :where-from name)))
(when (eq where :declared)
- (setf (leaf-type fun) type)
- (assert-definition-type
- fun type
- :unwinnage-fun #'compiler-notify
- :where "proclamation"
- :really-assert (not (awhen (info :function :info name)
- (ir1-attributep (fun-info-attributes it)
- explicit-check)))))))
+ (let ((type (massage-global-definition-type type fun)))
+ (setf (leaf-type fun) type)
+ (assert-definition-type
+ fun type
+ :unwinnage-fun #'compiler-notify
+ :where "proclamation"
+ :really-assert (not (awhen (info :function :info name)
+ (ir1-attributep (fun-info-attributes it)
+ explicit-check))))))))
+
+;;; If the function has both &REST and &KEY, FIND-OPTIONAL-DISPATCH-TYPES
+;;; doesn't complain about the type missing &REST -- which is good, because in
+;;; that case &REST is really an implementation detail and not part of the
+;;; interface. However since we set the leaf type missing &REST from there
+;;; would be a bad thing -- to make up a new type if necessary.
+(defun massage-global-definition-type (type fun)
+ (if (and (fun-type-p type)
+ (optional-dispatch-p fun)
+ (optional-dispatch-keyp fun)
+ (optional-dispatch-more-entry fun)
+ (not (or (fun-type-rest type)
+ (fun-type-wild-args type))))
+ (make-fun-type :required (fun-type-required type)
+ :optional (fun-type-optional type)
+ :rest *universal-type*
+ :keyp (fun-type-keyp type)
+ :keywords (fun-type-keywords type)
+ :allowp (fun-type-allowp type)
+ :returns (fun-type-returns type))
+ type))
\f
;;; Call FUN with (arg-lvar arg-type)
(defun map-combination-args-and-types (fun call)
;;; 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)
+(defun assert-call-type (call type &optional (trusted t))
(declare (type combination call) (type fun-type type))
- (derive-node-type call (fun-type-returns type))
- (let ((policy (lexenv-policy (node-lexenv call))))
+ (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 lose cause us not the be in a tail-position anymore.
+ (when (and lvar
+ (not (return-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)
- (assert-lvar-type arg type policy))
+ (when (assert-lvar-type arg type policy)
+ (unless trusted (reoptimize-lvar arg))))
call))
(values))
\f