From a574de23a28d9df8b89bdb4fa96f608b6f5777f0 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 30 Aug 2003 06:44:45 +0000 Subject: [PATCH] 0.8.3.15: * New function MAP-COMBINATION-ARGS-AND-TYPES; ... use it in ASSERT-CALL-TYPE and %continuation-%externally-checkable-type; ... C-E-C-T now works for &KEYS; * factor out check for full-like calls; * maybe flush C-E-C-T in local call conversion. --- src/compiler/checkgen.lisp | 41 +++++++++---------- src/compiler/ctype.lisp | 40 ++++++++++++++++++ src/compiler/ir1opt.lisp | 84 ++++++++++++-------------------------- src/compiler/ir1tran-lambda.lisp | 5 +-- src/compiler/locall.lisp | 4 ++ src/compiler/node.lisp | 8 ++++ version.lisp-expr | 2 +- 7 files changed, 100 insertions(+), 84 deletions(-) diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 5313441..5a9d009 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -280,27 +280,26 @@ (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 diff --git a/src/compiler/ctype.lisp b/src/compiler/ctype.lisp index 1c2296b..3748cf8 100644 --- a/src/compiler/ctype.lisp +++ b/src/compiler/ctype.lisp @@ -774,6 +774,46 @@ (ir1-attributep (fun-info-attributes it) explicit-check))))))) +;;; 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)) + ;;;; FIXME: Move to some other file. (defun check-catch-tag-type (tag) (declare (type continuation tag)) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index ff627a5..f7e4318 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -87,34 +87,31 @@ (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)) @@ -220,37 +217,6 @@ (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)) ;;;; IR1-OPTIMIZE diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp index 95fc019..ef8d4e0 100644 --- a/src/compiler/ir1tran-lambda.lisp +++ b/src/compiler/ir1tran-lambda.lisp @@ -298,12 +298,12 @@ (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 @@ -327,7 +327,6 @@ (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)) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index 360c241..56e0ee4 100644 --- a/src/compiler/locall.lisp +++ b/src/compiler/locall.lisp @@ -89,6 +89,10 @@ (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) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 73b38cd..a61208e 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -1193,6 +1193,14 @@ "")) 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. diff --git a/version.lisp-expr b/version.lisp-expr index 50ac590..58dec1e 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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" -- 1.7.10.4