diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp index c8d7aec5bf4b9bc5a5bf4ae33715449f30db325b..8b408887c7503f704236e18901ec1cb1cc82372c 100644 --- a/compiler/checkgen.lisp +++ b/compiler/checkgen.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.24 1994/10/31 04:27:28 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/checkgen.lisp,v 1.25 1998/01/06 16:51:51 dtc Exp $") ;;; ;;; ********************************************************************** ;;; @@ -493,39 +493,48 @@ ;;; the hairy case, we must indicate to LTN that it must choose a safe ;;; implementation, since IR2 conversion will choke on the check. ;;; +;;; The generation of the type checks is delayed until all the type +;;; check decisions have been made because the generation of the type +;;; checks creates new nodes who's derived types aren't always updated +;;; which may lead to inappropriate template choices due to the +;;; modification of argument types. +;;; (defun generate-type-checks (component) - (do-blocks (block component) - (when (block-type-check block) - (do-nodes (node cont block) - (let ((type-check (continuation-type-check cont))) - (unless (member type-check '(nil :error :deleted)) - (let ((atype (continuation-asserted-type cont))) - (do-uses (use cont) - (unless (values-types-intersect (node-derived-type use) - atype) - (mark-error-continuation cont) - (unless (policy node (= brevity 3)) - (do-type-warning use)))))) + (collect ((conts)) + (do-blocks (block component) + (when (block-type-check block) + (do-nodes (node cont block) + (let ((type-check (continuation-type-check cont))) + (unless (member type-check '(nil :error :deleted)) + (let ((atype (continuation-asserted-type cont))) + (do-uses (use cont) + (unless (values-types-intersect (node-derived-type use) + atype) + (mark-error-continuation cont) + (unless (policy node (= brevity 3)) + (do-type-warning use)))))) + (when (and (eq type-check t) + (not *byte-compiling*)) + (if (probable-type-check-p cont) + (conts cont) + (setf (continuation-%type-check cont) :no-check))))) + + (setf (block-type-check block) nil))) + + (dolist (cont (conts)) + (multiple-value-bind (check types) + (continuation-check-types cont) + (ecase check + (:simple) + (:hairy + (convert-type-check cont types)) + (:too-hairy + (let* ((context (continuation-dest cont)) + (*compiler-error-context* context)) + (when (policy context (>= safety brevity)) + (compiler-note + "Type assertion too complex to check:~% ~S." + (type-specifier (continuation-asserted-type cont))))) + (setf (continuation-%type-check cont) :deleted)))))) - (when (and (eq type-check t) - (not *byte-compiling*)) - (if (probable-type-check-p cont) - (multiple-value-bind (check types) - (continuation-check-types cont) - (ecase check - (:simple) - (:hairy - (convert-type-check cont types)) - (:too-hairy - (let* ((context (continuation-dest cont)) - (*compiler-error-context* context)) - (when (policy context (>= safety brevity)) - (compiler-note - "Type assertion too complex to check:~% ~S." - (type-specifier (continuation-asserted-type cont))))) - (setf (continuation-%type-check cont) :deleted)))) - (setf (continuation-%type-check cont) :no-check))))) - - (setf (block-type-check block) nil))) - (undefined-value))