From: Alexey D. <ade...@us...> - 2002-09-27 11:31:02
|
Update of /cvsroot/sbcl/sbcl/src/compiler In directory usw-pr-cvs1:/tmp/cvs-serv27039a/src/compiler Modified Files: checkgen.lisp ir1opt.lisp ir1tran.lisp ir1util.lisp node.lisp Log Message: 0.7.8.2: Added type checks for explicit THEs in arguments in full calls. Simple type checking is not still performed. Index: checkgen.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v retrieving revision 1.24 retrieving revision 1.25 diff -u -d -r1.24 -r1.25 --- checkgen.lisp 15 Sep 2002 18:18:12 -0000 1.24 +++ checkgen.lisp 27 Sep 2002 11:30:57 -0000 1.25 @@ -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 Index: ir1opt.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v retrieving revision 1.41 retrieving revision 1.42 diff -u -d -r1.41 -r1.42 --- ir1opt.lisp 21 Sep 2002 10:24:08 -0000 1.41 +++ ir1opt.lisp 27 Sep 2002 11:30:58 -0000 1.42 @@ -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)) Index: ir1tran.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v retrieving revision 1.89 retrieving revision 1.90 diff -u -d -r1.89 -r1.90 --- ir1tran.lisp 21 Sep 2002 05:43:20 -0000 1.89 +++ ir1tran.lisp 27 Sep 2002 11:30:58 -0000 1.90 @@ -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)) Index: ir1util.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v retrieving revision 1.43 retrieving revision 1.44 diff -u -d -r1.43 -r1.44 --- ir1util.lisp 21 Sep 2002 10:24:08 -0000 1.43 +++ ir1util.lisp 27 Sep 2002 11:30:58 -0000 1.44 @@ -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)) Index: node.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- node.lisp 15 Sep 2002 18:18:13 -0000 1.30 +++ node.lisp 27 Sep 2002 11:30:58 -0000 1.31 @@ -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 |