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
-------------------------------------------------------
This sf.net email is sponsored by:ThinkGeek
Welcome to geek heaven.
http://thinkgeek.com/sf
|
