From 38116cfe938c5fe0e2bcc59bf068f3982f3174d7 Mon Sep 17 00:00:00 2001 From: dtc <dtc> Date: Tue, 6 Jan 1998 16:51:51 +0000 Subject: [PATCH] Delay the generation of the type checks 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. --- compiler/checkgen.lisp | 77 +++++++++++++++++++++++------------------- 1 file changed, 43 insertions(+), 34 deletions(-) diff --git a/compiler/checkgen.lisp b/compiler/checkgen.lisp index c8d7aec5b..8b408887c 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)) -- GitLab