From: Alexey Dejneka Date: Fri, 27 Sep 2002 11:30:57 +0000 (+0000) Subject: 0.7.8.2: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=ae97d229fa1b74032a5c7cba21840598da6726c8;p=sbcl.git 0.7.8.2: Added type checks for explicit THEs in arguments in full calls. Simple type checking is not still performed. --- diff --git a/src/compiler/checkgen.lisp b/src/compiler/checkgen.lisp index 1712cfe..6ada02b 100644 --- a/src/compiler/checkgen.lisp +++ b/src/compiler/checkgen.lisp @@ -260,19 +260,26 @@ (let ((kind (basic-combination-kind dest))) (cond ((eq cont (basic-combination-fun dest)) t) ((eq kind :local) t) - ((member kind '(:full :error)) nil) + ((not (eq (continuation-asserted-type cont) + (continuation-externally-checkable-type cont))) + ;; There is an explicit assertion. + t) + ((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.) + nil) + + ((eq kind :error) nil) ;; :ERROR means that we have an invalid syntax of ;; the call and the callee will detect it before - ;; thinking about types. When KIND is :FULL, the - ;; theory is that the type assertion is probably - ;; 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.) + ;; thinking about types. ((fun-info-ir2-convert kind) t) (t diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 98f4d9b..3287929 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -118,6 +118,41 @@ (declaim (ftype (function (continuation) ctype) continuation-type)) (defun continuation-type (cont) (single-value-type (continuation-derived-type cont))) + +;;; If CONT is an argument of a function, return a type which the +;;; function checks CONT for. +#!-sb-fluid (declaim (inline continuation-externally-checkable-type)) +(defun continuation-externally-checkable-type (cont) + (or (continuation-%externally-checkable-type cont) + (%continuation-%externally-checkable-type cont))) +(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))) + (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) + (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 (setf (continuation-%externally-checkable-type arg) + type)) + (continuation-%externally-checkable-type cont))))))) ;;;; interface routines used by optimizers @@ -627,6 +662,7 @@ (new-block (continuation-starts-block new-cont))) (link-node-to-previous-continuation new-node new-cont) (setf (continuation-dest new-cont) new-node) + (setf (continuation-%externally-checkable-type new-cont) nil) (add-continuation-use new-node dummy-cont) (setf (block-last new-block) new-node) @@ -1615,7 +1651,8 @@ (flush-dest (combination-fun use)) (let ((fun-cont (basic-combination-fun call))) (setf (continuation-dest fun-cont) use) - (setf (combination-fun use) fun-cont)) + (setf (combination-fun use) fun-cont) + (setf (continuation-%externally-checkable-type fun-cont) nil)) (setf (combination-kind use) :local) (setf (functional-kind fun) :let) (flush-dest (first (basic-combination-args call))) @@ -1645,7 +1682,8 @@ (setf (combination-kind node) :full) (let ((args (combination-args use))) (dolist (arg args) - (setf (continuation-dest arg) node)) + (setf (continuation-dest arg) node) + (setf (continuation-%externally-checkable-type arg) nil)) (setf (combination-args use) nil) (flush-dest list) (setf (combination-args node) args)) diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp index 456e025..0002cb2 100644 --- a/src/compiler/ir1tran.lisp +++ b/src/compiler/ir1tran.lisp @@ -758,6 +758,7 @@ (setf (continuation-dest fun-cont) node) (assert-continuation-type fun-cont (specifier-type '(or function symbol))) + (setf (continuation-%externally-checkable-type fun-cont) nil) (collect ((arg-conts)) (let ((this-start fun-cont)) (dolist (arg args) @@ -1494,6 +1495,7 @@ (setf (lambda-tail-set lambda) tail-set) (setf (lambda-return lambda) return) (setf (continuation-dest result) return) + (setf (continuation-%externally-checkable-type result) nil) (setf (block-last block) return) (link-node-to-previous-continuation return result) (use-continuation return dummy)) diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp index e6637c1..c608b66 100644 --- a/src/compiler/ir1util.lisp +++ b/src/compiler/ir1util.lisp @@ -151,7 +151,8 @@ (nsubst new old (basic-combination-args dest)))))) (flush-dest old) - (setf (continuation-dest new) dest)) + (setf (continuation-dest new) dest) + (setf (continuation-%externally-checkable-type new) nil)) (values)) ;;; Replace all uses of OLD with uses of NEW, where NEW has an @@ -794,6 +795,7 @@ (unless (eq (continuation-kind cont) :deleted) (aver (continuation-dest cont)) (setf (continuation-dest cont) nil) + (setf (continuation-%externally-checkable-type cont) nil) (do-uses (use cont) (let ((prev (node-prev use))) (unless (eq (continuation-kind prev) :deleted) @@ -849,6 +851,7 @@ (setf (continuation-kind cont) :deleted) (setf (continuation-dest cont) nil) + (setf (continuation-%externally-checkable-type cont) nil) (setf (continuation-next cont) nil) (setf (continuation-asserted-type cont) *empty-type*) (setf (continuation-%derived-type cont) *empty-type*) @@ -1177,7 +1180,8 @@ (before-args (subseq outside-args 0 arg-position)) (after-args (subseq outside-args (1+ arg-position)))) (dolist (arg inside-args) - (setf (continuation-dest arg) outside)) + (setf (continuation-dest arg) outside) + (setf (continuation-%externally-checkable-type arg) nil)) (setf (combination-args inside) nil) (setf (combination-args outside) (append before-args inside-args after-args)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 3671b05..eff4303 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -127,6 +127,9 @@ ;; This is computed lazily by CONTINUATION-DERIVED-TYPE, so use ;; CONTINUATION-TYPE-CHECK instead of the %'ed slot accessor. (%type-check t :type (member t nil :deleted :no-check)) + ;; Cached type which is checked by DEST. If NIL, then this must be + ;; recomputed: see CONTINUATION-EXTERNALLY-CHECKABLE-TYPE. + (%externally-checkable-type nil :type (or null ctype)) ;; something or other that the back end annotates this continuation with (info nil) ;; uses of this continuation in the lexical environment. They are diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index db25462..afabf2b 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -359,6 +359,24 @@ BUG 48c, not yet fixed: (raises-error? (foo 3) type-error) (raises-error? (foo 3f0) type-error) + +;;; until 0.8.2 SBCL did not check THEs in arguments +(defun the-in-arguments-aux (x) + x) +(defun the-in-arguments-1 (x) + (list x (the-in-arguments-aux (the (single-float 0s0) x)))) +(defun the-in-arguments-2 (x) + (list x (the-in-arguments-aux (the single-float x)))) + +(multiple-value-bind (result condition) + (ignore-errors (the-in-arguments-1 1)) + (assert (null result)) + (assert (typep condition 'type-error))) +#+nil +(multiple-value-bind (result condition) + (ignore-errors (the-in-arguments-2 1)) + (assert (null result)) + (assert (typep condition 'type-error))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself diff --git a/version.lisp-expr b/version.lisp-expr index 752a85d..b7b97de 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; internal versions off the main CVS branch, it gets hairier, e.g. ;;; "0.pre7.14.flaky4.13".) -"0.7.8.1" +"0.7.8.2"