Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] CVS: sbcl/src/compiler checkgen.lisp,1.37,1.38 ctype.lisp,1.26,1.27 ir1opt.lisp,1.73,1.74 ir1tran-lambda.lisp,1.9,1.10 locall.lisp,1.50,1.51 node.lisp,1.41,1.42
From: Alexey Dejneka <adejneka@us...> - 2003-08-30 06:45
|
Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1:/tmp/cvs-serv22341/src/compiler
Modified Files:
checkgen.lisp ctype.lisp ir1opt.lisp ir1tran-lambda.lisp
locall.lisp node.lisp
Log Message:
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.
Index: checkgen.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/checkgen.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- checkgen.lisp 27 Jul 2003 15:05:32 -0000 1.37
+++ checkgen.lisp 30 Aug 2003 06:44:45 -0000 1.38
@@ -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
Index: ctype.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ctype.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- ctype.lisp 17 Aug 2003 17:17:07 -0000 1.26
+++ ctype.lisp 30 Aug 2003 06:44:45 -0000 1.27
@@ -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))
Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- ir1opt.lisp 26 Aug 2003 08:58:31 -0000 1.73
+++ ir1opt.lisp 30 Aug 2003 06:44:45 -0000 1.74
@@ -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
Index: ir1tran-lambda.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran-lambda.lisp,v
retrieving revision 1.9
retrieving revision 1.10
diff -u -d -r1.9 -r1.10
--- ir1tran-lambda.lisp 20 Aug 2003 18:55:22 -0000 1.9
+++ ir1tran-lambda.lisp 30 Aug 2003 06:44:45 -0000 1.10
@@ -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))
Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- locall.lisp 24 Jun 2003 04:36:38 -0000 1.50
+++ locall.lisp 30 Aug 2003 06:44:45 -0000 1.51
@@ -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)
Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -d -r1.41 -r1.42
--- node.lisp 4 Jun 2003 06:03:13 -0000 1.41
+++ node.lisp 30 Aug 2003 06:44:45 -0000 1.42
@@ -1193,6 +1193,14 @@
"<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.
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/compiler checkgen.lisp,1.37,1.38 ctype.lisp,1.26,1.27 ir1opt.lisp,1.73,1.74 ir1tran-lambda.lisp,1.9,1.10 locall.lisp,1.50,1.51 node.lisp,1.41,1.42 | Alexey Dejneka <adejneka@us...> |