(declare (type cast cast))
(let* ((cont (node-cont cast))
(dest (continuation-dest cont)))
- (not (or (not (cast-type-check cast))
- (and (combination-p dest)
- (let ((kind (combination-kind dest)))
- (or (eq kind :full)
- ;; The theory is that the type assertion is
- ;; from a declaration in (or on) the callee,
- ;; so the callee should be able to do the
- ;; check. We want to let the callee do the
- ;; check, because it is possible that by the
- ;; time of call that declaration will be
- ;; changed and we do not want to make people
- ;; recompile all calls to a function when they
- ;; were originally compiled with a bad
- ;; declaration. (See also bug 35.)
- (and (fun-info-p kind)
- (null (fun-info-templates kind))
- (not (fun-info-ir2-convert kind)))))
- (and
- (immediately-used-p cont cast)
- (values-subtypep (continuation-externally-checkable-type cont)
- (cast-type-to-check cast))))))))
+ (cond ((not (cast-type-check cast))
+ nil)
+ ((and (combination-p dest)
+ (call-full-like-p dest)
+ ;; The theory is that the type assertion is
+ ;; from a declaration in (or on) the callee,
+ ;; so the callee should be able to do the
+ ;; check. We want to let the callee do the
+ ;; check, because it is possible that by the
+ ;; time of call that declaration will be
+ ;; changed and we do not want to make people
+ ;; recompile all calls to a function when they
+ ;; were originally compiled with a bad
+ ;; declaration. (See also bug 35.)
+ (immediately-used-p cont cast)
+ (values-subtypep (continuation-externally-checkable-type cont)
+ (cast-type-to-check cast)))
+ nil)
+ (t
+ t))))
;;; Return true if CONT is a continuation whose type the back end is
;;; likely to want to check. Since we don't know what template the
(ir1-attributep (fun-info-attributes it)
explicit-check)))))))
\f
+;;; Call FUN with (arg-continuation arg-type)
+(defun map-combination-args-and-types (fun call)
+ (declare (type function fun) (type combination call))
+ (binding* ((type (continuation-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 (continuation-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)
+ (declare (type combination call) (type fun-type type))
+ (derive-node-type call (fun-type-returns type))
+ (let ((policy (lexenv-policy (node-lexenv call))))
+ (map-combination-args-and-types
+ (lambda (arg type)
+ (assert-continuation-type arg type policy))
+ call))
+ (values))
+\f
;;;; FIXME: Move to some other file.
(defun check-catch-tag-type (tag)
(declare (type continuation tag))
(defun %continuation-%externally-checkable-type (cont)
(declare (type continuation cont))
(let ((dest (continuation-dest cont)))
- (if (not (and dest (combination-p dest)))
- ;; TODO: MV-COMBINATION
- (setf (continuation-%externally-checkable-type cont) *wild-type*)
- (let* ((fun (combination-fun dest))
- (args (combination-args dest))
- (fun-type (continuation-type fun)))
- (setf (continuation-%externally-checkable-type fun) *wild-type*)
- (if (or (not (fun-type-p fun-type))
- ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
- (fun-type-wild-args fun-type))
- (progn (dolist (arg args)
- (when arg
- (setf (continuation-%externally-checkable-type arg)
- *wild-type*)))
- *wild-type*)
- (let* ((arg-types (append (fun-type-required fun-type)
- (fun-type-optional fun-type)
- (let ((rest (list (or (fun-type-rest fun-type)
- *wild-type*))))
- (setf (cdr rest) rest)))))
- ;; TODO: &KEY
- (loop
- for arg of-type continuation in args
- and type of-type ctype in arg-types
- do (when arg
- (setf (continuation-%externally-checkable-type arg)
- (coerce-to-values type))))
- (continuation-%externally-checkable-type cont)))))))
+ (if (not (and dest
+ (combination-p dest)))
+ ;; TODO: MV-COMBINATION
+ (setf (continuation-%externally-checkable-type cont) *wild-type*)
+ (let* ((fun (combination-fun dest))
+ (args (combination-args dest))
+ (fun-type (continuation-type fun)))
+ (setf (continuation-%externally-checkable-type fun) *wild-type*)
+ (if (or (not (call-full-like-p dest))
+ (not (fun-type-p fun-type))
+ ;; FUN-TYPE might be (AND FUNCTION (SATISFIES ...)).
+ (fun-type-wild-args fun-type))
+ (dolist (arg args)
+ (when arg
+ (setf (continuation-%externally-checkable-type arg)
+ *wild-type*)))
+ (map-combination-args-and-types
+ (lambda (arg type)
+ (setf (continuation-%externally-checkable-type arg)
+ (acond ((continuation-%externally-checkable-type arg)
+ (values-type-intersection
+ it (coerce-to-values type)))
+ (t (coerce-to-values type)))))
+ dest)))))
+ (continuation-%externally-checkable-type cont))
(declaim (inline flush-continuation-externally-checkable-type))
(defun flush-continuation-externally-checkable-type (cont)
(declare (type continuation cont))
(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
-;;; keyword positions.
-(defun assert-call-type (call type)
- (declare (type combination call) (type fun-type type))
- (derive-node-type call (fun-type-returns type))
- (let ((args (combination-args call))
- (policy (lexenv-policy (node-lexenv call))))
- (dolist (req (fun-type-required type))
- (when (null args) (return-from assert-call-type))
- (let ((arg (pop args)))
- (assert-continuation-type arg req policy)))
- (dolist (opt (fun-type-optional type))
- (when (null args) (return-from assert-call-type))
- (let ((arg (pop args)))
- (assert-continuation-type arg opt policy)))
-
- (let ((rest (fun-type-rest type)))
- (when rest
- (dolist (arg args)
- (assert-continuation-type arg rest policy))))
-
- (dolist (key (fun-type-keywords type))
- (let ((name (key-info-name key)))
- (do ((arg args (cddr arg)))
- ((null arg))
- (when (eq (continuation-value (first arg)) name)
- (assert-continuation-type
- (second arg) (key-info-type key)
- policy))))))
- (values))
\f
;;;; IR1-OPTIMIZE
(setf (lambda-home lambda) lambda)
(collect ((svars)
- (new-venv nil cons))
+ (new-venv nil cons))
(dolist (var vars)
;; As far as I can see, LAMBDA-VAR-HOME should never have
;; been set before. Let's make sure. -- WHN 2001-09-29
- (aver (null (lambda-var-home var)))
+ (aver (not (lambda-var-home var)))
(setf (lambda-var-home var) lambda)
(let ((specvar (lambda-var-specvar var)))
(cond (specvar
(setf (lambda-tail-set lambda) tail-set)
(setf (lambda-return lambda) return)
(setf (continuation-dest result) return)
- (flush-continuation-externally-checkable-type result)
(setf (block-last block) return)
(link-node-to-previous-continuation return result)
(use-continuation return dummy))
(declare (type ref ref) (type combination call) (type clambda fun))
(propagate-to-args call fun)
(setf (basic-combination-kind call) :local)
+ (unless (call-full-like-p call)
+ (dolist (arg (basic-combination-args call))
+ (when arg
+ (flush-continuation-externally-checkable-type arg))))
(pushnew fun (lambda-calls-or-closes (node-home-lambda call)))
(merge-tail-sets call fun)
(change-ref-leaf ref fun)
"<deleted>"))
args)))
+(defun call-full-like-p (call)
+ (declare (type combination call))
+ (let ((kind (basic-combination-kind call)))
+ (or (eq kind :full)
+ (and (fun-info-p kind)
+ (null (fun-info-templates kind))
+ (not (fun-info-ir2-convert kind))))))
+
;;; An MV-COMBINATION is to MULTIPLE-VALUE-CALL as a COMBINATION is to
;;; FUNCALL. This is used to implement all the multiple-value
;;; receiving forms.
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.3.14"
+"0.8.3.15"
projects / sbcl.git / commitdiff