From a7c2a16d0c2be6709becc962be1cb5e0aeda68c6 Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sat, 4 Jan 2003 10:12:43 +0000 Subject: [PATCH] 0.7.11.2: Merged in the mti-1202 branch: ... restored constraint propagation from type assertions; ... removed bogus type declarations in WITH-PACKAGE-ITERATOR; --- BUGS | 34 ----- NEWS | 3 + src/code/loop.lisp | 8 +- src/code/target-pathname.lisp | 23 +-- src/compiler/constraint.lisp | 337 +++++++++++++++++++++++++---------------- src/compiler/copyprop.lisp | 4 +- src/compiler/fndb.lisp | 3 +- src/compiler/ir1opt.lisp | 61 +++++--- src/compiler/node.lisp | 20 +-- src/compiler/sset.lisp | 6 +- src/compiler/vop.lisp | 2 +- tests/compiler.pure.lisp | 9 ++ version.lisp-expr | 2 +- 13 files changed, 288 insertions(+), 224 deletions(-) diff --git a/BUGS b/BUGS index 0c1771c..8d0ae41 100644 --- a/BUGS +++ b/BUGS @@ -293,40 +293,6 @@ WORKAROUND: then requesting a BACKTRACE at the debugger prompt gives no information about where in the user program the problem occurred. -62: - The compiler is supposed to do type inference well enough that - the declaration in - (TYPECASE X - ((SIMPLE-ARRAY SINGLE-FLOAT) - (LOCALLY - (DECLARE (TYPE (SIMPLE-ARRAY SINGLE-FLOAT) X)) - ..)) - ..) - is redundant. However, as reported by Juan Jose Garcia Ripoll for - CMU CL, it sometimes doesn't. Adding declarations is a pretty good - workaround for the problem for now, but can't be done by the TYPECASE - macros themselves, since it's too hard for the macro to detect - assignments to the variable within the clause. - Note: The compiler *is* smart enough to do the type inference in - many cases. This case, derived from a couple of MACROEXPAND-1 - calls on Ripoll's original test case, - (DEFUN NEGMAT (A) - (DECLARE (OPTIMIZE SPEED (SAFETY 0))) - (COND ((TYPEP A '(SIMPLE-ARRAY SINGLE-FLOAT)) NIL - (LET ((LENGTH (ARRAY-TOTAL-SIZE A))) - (LET ((I 0) (G2554 LENGTH)) - (DECLARE (TYPE REAL G2554) (TYPE REAL I)) - (TAGBODY - SB-LOOP::NEXT-LOOP - (WHEN (>= I G2554) (GO SB-LOOP::END-LOOP)) - (SETF (ROW-MAJOR-AREF A I) (- (ROW-MAJOR-AREF A I))) - (GO SB-LOOP::NEXT-LOOP) - SB-LOOP::END-LOOP)))))) - demonstrates the problem; but the problem goes away if the TAGBODY - and GO forms are removed (leaving the SETF in ordinary, non-looping - code), or if the TAGBODY and GO forms are retained, but the - assigned value becomes 0.0 instead of (- (ROW-MAJOR-AREF A I)). - 63: Paul Werkowski wrote on cmucl-imp@cons.org 2000-11-15 I am looking into this problem that showed up on the cmucl-help diff --git a/NEWS b/NEWS index ce8d274..d7f2e71 100644 --- a/NEWS +++ b/NEWS @@ -1483,6 +1483,9 @@ changes in sbcl-0.7.11 relative to sbcl-0.7.10: change to the DEFSTRUCT-DESCRIPTION structure, and again because of the new implementation of DEFINE-COMPILER-MACRO. +changes in sbcl-0.7.12 relative to sbcl-0.7.11: + * fixed bug 62: constraints were not propagated into a loop. + planned incompatible changes in 0.7.x: * (not done yet, but planned:) When the profiling interface settles down, maybe in 0.7.x, maybe later, it might impact TRACE. They both diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 43962bd..027ec57 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -1296,10 +1296,10 @@ code to be loaded. (defun loop-do-repeat () (loop-disallow-conditional :repeat) (let ((form (loop-get-form)) - (type 'real)) - (let ((var (loop-make-var (gensym "LOOP-REPEAT-") form type))) - (push `(when (minusp (decf ,var)) (go end-loop)) *loop-before-loop*) - (push `(when (minusp (decf ,var)) (go end-loop)) *loop-after-body*) + (type 'integer)) + (let ((var (loop-make-var (gensym "LOOP-REPEAT-") `(ceiling ,form) type))) + (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-before-loop*) + (push `(if (<= ,var 0) (go end-loop) (decf ,var)) *loop-after-body*) ;; FIXME: What should ;; (loop count t into a ;; repeat 3 diff --git a/src/code/target-pathname.lisp b/src/code/target-pathname.lisp index 9121c1c..6ae6f41 100644 --- a/src/code/target-pathname.lisp +++ b/src/code/target-pathname.lisp @@ -318,9 +318,9 @@ (simple-string (check-for pred piece)) (cons - (case (car in) + (case (car piece) (:character-set - (check-for pred (cdr in)))))) + (check-for pred (cdr piece)))))) (return t)))) (list (dolist (x in) @@ -1474,15 +1474,9 @@ a host-structure or string." (canonicalize-logical-pathname-translations translations host)) (setf (logical-host-translations host) translations))) -;;; KLUDGE: Ordinarily known functions aren't defined recursively, and -;;; it's common for compiler problems (e.g. missing/broken -;;; optimization transforms) to cause them to recurse inadvertently, -;;; so the compiler should warn about it. But the natural definition -;;; of TRANSLATE-LOGICAL-PATHNAME *is* recursive; and we don't want -;;; the warning, so we hide the definition of T-L-P in this -;;; differently named function so that the compiler won't warn about -;;; it. -- WHN 2001-09-16 -(defun %translate-logical-pathname (pathname) +(defun translate-logical-pathname (pathname &key) + #!+sb-doc + "Translate PATHNAME to a physical pathname, which is returned." (declare (type pathname-designator pathname) (values (or null pathname))) (typecase pathname @@ -1499,13 +1493,6 @@ a host-structure or string." (pathname pathname) (t (translate-logical-pathname (pathname pathname))))) -(defun translate-logical-pathname (pathname &key) - #!+sb-doc - "Translate PATHNAME to a physical pathname, which is returned." - (declare (type pathname-designator pathname) - (values (or null pathname))) - (%translate-logical-pathname pathname)) - (defvar *logical-pathname-defaults* (%make-logical-pathname (make-logical-host :name "BOGUS") :unspecific diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp index 823a163..507eaf8 100644 --- a/src/compiler/constraint.lisp +++ b/src/compiler/constraint.lisp @@ -11,6 +11,44 @@ ;;;; provided with absolutely no warranty. See the COPYING and CREDITS ;;;; files for more information. +;;; TODO: +;;; +;;; -- documentation +;;; +;;; -- MV-BIND, :ASSIGNMENT + +;;; Problems: +;;; +;;; -- Constraint propagation badly interacts with bottom-up type +;;; inference. Consider +;;; +;;; (defun foo (n &aux (i 42)) +;;; (declare (optimize speed)) +;;; (declare (fixnum n) +;;; #+nil (type (integer 0) i)) +;;; (tagbody +;;; (setq i 0) +;;; :loop +;;; (when (>= i n) (go :exit)) +;;; (setq i (1+ i)) +;;; (go :loop) +;;; :exit)) +;;; +;;; In this case CP cannot even infer that I is of class INTEGER. +;;; +;;; -- In the above example if we place the check after SETQ, CP will +;;; fail to infer (< I FIXNUM): is does not understand that this +;;; constraint follows from (TYPEP I (INTEGER 0 0)). + +;;; BUGS: +;;; +;;; -- this code does not check whether SET appears between REF and a +;;; test (bug 233b) +;;; +;;; -- type check is assumed to be inserted immediately after a node +;;; producing the value; it disagrees with the rest of Python (bug +;;; 233a) + (in-package "SB!C") (defstruct (constraint @@ -20,11 +58,11 @@ ;; the kind of constraint we have: ;; ;; TYPEP - ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is + ;; X is a LAMBDA-VAR and Y is a CTYPE. The value of X is ;; constrained to be of type Y. ;; ;; > or < - ;; X is a lambda-var and Y is a CTYPE. The relation holds + ;; X is a lambda-var and Y is a CTYPE. The relation holds ;; between X and some object of type Y. ;; ;; EQL @@ -34,7 +72,7 @@ ;; The operands to the relation. (x nil :type lambda-var) (y nil :type (or ctype lambda-var constant)) - ;; If true, negates the sense of the constraint, so the relation + ;; If true, negates the sense of the constraint, so the relation ;; does *not* hold. (not-p nil :type boolean)) @@ -95,6 +133,8 @@ (when (ref-p use) (ok-ref-lambda-var use)))) +;;;; Searching constraints + ;;; Add the indicated test constraint to BLOCK, marking the block as ;;; having a new assertion when the constriant was not already ;;; present. We don't add the constraint if the block has multiple @@ -192,42 +232,7 @@ (setf (block-test-modified block) nil) (values)) -;;; Compute the initial flow analysis sets for BLOCK: -;;; -- For any lambda-var ref with a type check, add that constraint. -;;; -- For any LAMBDA-VAR set, delete all constraints on that var, and add -;;; those constraints to the set nuked by this block. -(defun find-block-type-constraints (block) - (declare (type cblock block)) - (let ((gen (make-sset))) - (collect ((kill nil adjoin)) - - (let ((test (block-test-constraint block))) - (when test - (sset-union gen test))) - - (do-nodes (node cont block) - (typecase node - (ref - (when (continuation-type-check cont) - (let ((var (ok-ref-lambda-var node))) - (when var - (let* ((atype (continuation-derived-type cont)) - (con (find-constraint 'typep var atype nil))) - (sset-adjoin con gen)))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (kill var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference gen cons)))))))) - - (setf (block-in block) nil) - (setf (block-gen block) gen) - (setf (block-kill-list block) (kill)) - (setf (block-out block) (copy-sset gen)) - (setf (block-type-asserted block) nil) - (values)))) +;;;; Applying constraints ;;; Return true if X is an integer NUMERIC-TYPE. (defun integer-type-p (x) @@ -383,38 +388,157 @@ (values)) +;;;; Flow analysis + +;;; Local propagation +;;; -- [TODO: For any LAMBDA-VAR ref with a type check, add that +;;; constraint.] +;;; -- For any LAMBDA-VAR set, delete all constraints on that var; add +;;; a type constraint based on the new value type. +(declaim (ftype (function (cblock sset + &key (:ref-preprocessor function) + (:set-preprocessor function)) + sset) + constraint-propagate-in-block)) +(defun constraint-propagate-in-block + (block gen &key ref-preprocessor set-preprocessor) + + (let ((test (block-test-constraint block))) + (when test + (sset-union gen test))) + + (do-nodes (node cont block) + (typecase node + (bind + (let ((fun (bind-lambda node))) + (when (eq (functional-kind fun) :let) + (loop with call = (continuation-dest + (node-cont (first (lambda-refs fun)))) + for var in (lambda-vars fun) + and val in (combination-args call) + when (and val + (lambda-var-constraints var) + ;; if VAR has no SETs, type inference is + ;; fully performed by IR1 optimizer + (lambda-var-sets var)) + do (let* ((type (continuation-type val)) + (con (find-constraint 'typep var type nil))) + (sset-adjoin con gen)))))) + (ref + (let ((var (ok-ref-lambda-var node))) + (when var + (when ref-preprocessor + (funcall ref-preprocessor node gen)) + (when (continuation-type-check cont) + (let* ((atype (continuation-derived-type cont)) + (con (find-constraint 'typep var atype nil))) + (sset-adjoin con gen)))))) + (cset + (let ((var (set-var node))) + (when (lambda-var-p var) + (when set-preprocessor + (funcall set-preprocessor var)) + (let ((cons (lambda-var-constraints var))) + (when cons + (sset-difference gen cons) + (let* ((type (node-derived-type node)) + (con (find-constraint 'typep var type nil))) + (sset-adjoin con gen))))))))) + + gen) + +;;; BLOCK-KILL is just a list of the LAMBDA-VARs killed, so we must +;;; compute the kill set when there are any vars killed. We bum this a +;;; bit by special-casing when only one var is killed, and just using +;;; that var's constraints as the kill set. This set could possibly be +;;; precomputed, but it would have to be invalidated whenever any +;;; constraint is added, which would be a pain. +(defun compute-block-out (block) + (declare (type cblock block)) + (let ((in (block-in block)) + (kill (block-kill block)) + (out (copy-sset (block-gen block)))) + (cond ((null kill) + (sset-union out in)) + ((null (rest kill)) + (let ((con (lambda-var-constraints (first kill)))) + (if con + (sset-union-of-difference out in con) + (sset-union out in)))) + (t + (let ((kill-set (make-sset))) + (dolist (var kill) + (let ((con (lambda-var-constraints var))) + (when con + (sset-union kill-set con)))) + (sset-union-of-difference out in kill-set)))) + out)) + +;;; Compute the initial flow analysis sets for BLOCK: +;;; -- Compute IN/OUT sets; if OUT of a predecessor is not yet +;;; computed, assume it to be a universal set (this is only +;;; possible in a loop) +;;; +;;; Return T if we have found a loop. +(defun find-block-type-constraints (block) + (declare (type cblock block)) + (collect ((kill nil adjoin)) + (let ((gen (constraint-propagate-in-block + block (make-sset) + :set-preprocessor (lambda (var) + (kill var))))) + (setf (block-gen block) gen) + (setf (block-kill block) (kill)) + (setf (block-type-asserted block) nil) + (let* ((n (block-number block)) + (pred (block-pred block)) + (in nil) + (loop-p nil)) + (dolist (b pred) + (cond ((> (block-number b) n) + (if in + (sset-intersection in (block-out b)) + (setq in (copy-sset (block-out b))))) + (t (setq loop-p t)))) + (unless in + (bug "Unreachable code is found or flow graph is not ~ + properly depth-first ordered.")) + (setf (block-in block) in) + (setf (block-out block) (compute-block-out block)) + loop-p)))) + +;;; BLOCK-IN becomes the intersection of the OUT of the predecessors. +;;; Our OUT is: +;;; gen U (in - kill) +;;; +;;; Return True if we have done something. +(defun flow-propagate-constraints (block) + (let* ((pred (block-pred block)) + (in (progn (aver pred) + (let ((res (copy-sset (block-out (first pred))))) + (dolist (b (rest pred)) + (sset-intersection res (block-out b))) + res)))) + (setf (block-in block) in) + (let ((out (compute-block-out block))) + (if (sset= out (block-out block)) + nil + (setf (block-out block) out))))) + ;;; Deliver the results of constraint propagation to REFs in BLOCK. ;;; During this pass, we also do local constraint propagation by ;;; adding in constraints as we seem them during the pass through the ;;; block. (defun use-result-constraints (block) (declare (type cblock block)) - (let ((in (block-in block))) - - (let ((test (block-test-constraint block))) - (when test - (sset-union in test))) - - (do-nodes (node cont block) - (typecase node - (ref - (let ((var (ref-leaf node))) - (when (lambda-var-p var) - (let ((con (lambda-var-constraints var))) - (when con - (constrain-ref-type node con in) - (when (continuation-type-check cont) - (sset-adjoin - (find-constraint 'typep var - (continuation-asserted-type cont) - nil) - in))))))) - (cset - (let ((var (set-var node))) - (when (lambda-var-p var) - (let ((cons (lambda-var-constraints var))) - (when cons - (sset-difference in cons)))))))))) + (constraint-propagate-in-block + block (block-in block) + :ref-preprocessor (lambda (node cons) + (let ((var (ref-leaf node))) + (when (lambda-var-p var) + (let ((con (lambda-var-constraints var))) + (when con + (constrain-ref-type node con cons)))))))) ;;; Return true if VAR would have to be closed over if environment ;;; analysis ran now (i.e. if there are any uses that have a different @@ -446,48 +570,6 @@ (dolist (let (lambda-lets fun)) (frob let))))) -;;; BLOCK-IN becomes the intersection of the OUT of the predecessors. -;;; Our OUT is: -;;; out U (in - kill) -;;; -;;; BLOCK-KILL-LIST is just a list of the LAMBDA-VARs killed, so we must -;;; compute the kill set when there are any vars killed. We bum this a -;;; bit by special-casing when only one var is killed, and just using -;;; that var's constraints as the kill set. This set could possibly be -;;; precomputed, but it would have to be invalidated whenever any -;;; constraint is added, which would be a pain. -(defun flow-propagate-constraints (block) - (let* ((pred (block-pred block)) - (in (cond (pred - (let ((res (copy-sset (block-out (first pred))))) - (dolist (b (rest pred)) - (sset-intersection res (block-out b))) - res)) - (t - (let ((*compiler-error-context* (block-last block))) - (compiler-warn - "unreachable code in constraint ~ - propagation -- apparent compiler bug")) - (make-sset)))) - (kill-list (block-kill-list block)) - (out (block-out block))) - - (setf (block-in block) in) - (cond ((null kill-list) - (sset-union (block-out block) in)) - ((null (rest kill-list)) - (let ((con (lambda-var-constraints (first kill-list)))) - (if con - (sset-union-of-difference out in con) - (sset-union out in)))) - (t - (let ((kill-set (make-sset))) - (dolist (var kill-list) - (let ((con (lambda-var-constraints var))) - (when con - (sset-union kill-set con)))) - (sset-union-of-difference (block-out block) in kill-set)))))) - ;;; How many blocks does COMPONENT have? (defun component-n-blocks (component) (let ((result 0)) @@ -496,7 +578,7 @@ (incf result)) result)) -(defun constraint-propagate (component) +(defun constraint-propagate (component &aux (loop-p nil)) (declare (type component component)) (init-var-constraints component) @@ -504,27 +586,26 @@ (when (block-test-modified block) (find-test-constraints block))) + (unless (block-out (component-head component)) + (setf (block-out (component-head component)) (make-sset))) + (do-blocks (block component) - (cond ((block-type-asserted block) - (find-block-type-constraints block)) - (t - (setf (block-in block) nil) - (setf (block-out block) (copy-sset (block-gen block)))))) - - (setf (block-out (component-head component)) (make-sset)) - - (let (;; If we have to propagate changes more than this many times, - ;; something is wrong. - (max-n-changes-remaining (component-n-blocks component))) - (declare (type fixnum max-n-changes-remaining)) - (loop (aver (plusp max-n-changes-remaining)) - (decf max-n-changes-remaining) - (let ((did-something nil)) - (do-blocks (block component) - (when (flow-propagate-constraints block) - (setq did-something t))) - (unless did-something - (return))))) + (when (find-block-type-constraints block) + (setq loop-p t))) + + (when loop-p + (let (;; If we have to propagate changes more than this many times, + ;; something is wrong. + (max-n-changes-remaining (component-n-blocks component))) + (declare (type fixnum max-n-changes-remaining)) + (loop (aver (>= max-n-changes-remaining 0)) + (decf max-n-changes-remaining) + (let ((did-something nil)) + (do-blocks (block component) + (when (flow-propagate-constraints block) + (setq did-something t))) + (unless did-something + (return)))))) (do-blocks (block component) (use-result-constraints block)) diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp index 4977d1c..cd5293d 100644 --- a/src/compiler/copyprop.lisp +++ b/src/compiler/copyprop.lisp @@ -120,7 +120,7 @@ (sset-adjoin y kill)))))))))) (setf (block-out block) (copy-sset gen)) - (setf (block-kill-sset block) kill) + (setf (block-kill block) kill) (setf (block-gen block) gen)) (values)) @@ -137,7 +137,7 @@ (setf (block-in block) in) (sset-union-of-difference (block-out block) in - (block-kill-sset block)))) + (block-kill block)))) (defevent copy-deleted-move "Copy propagation deleted a move.") diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index b624399..7becf4a 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -1052,7 +1052,8 @@ ()) (defknown logical-pathname (pathname-designator) logical-pathname ()) -(defknown translate-logical-pathname (pathname-designator &key) pathname ()) +(defknown translate-logical-pathname (pathname-designator &key) pathname + (recursive)) (defknown load-logical-pathname-translations (string) t ()) (defknown logical-pathname-translations (logical-host-designator) list ()) diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 2badb1c..2e64da8 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -159,7 +159,7 @@ ;;;; interface routines used by optimizers ;;; This function is called by optimizers to indicate that something -;;; interesting has happened to the value of Cont. Optimizers must +;;; interesting has happened to the value of CONT. Optimizers must ;;; make sure that they don't call for reoptimization when nothing has ;;; happened, since optimization will fail to terminate. ;;; @@ -168,7 +168,7 @@ ;;; is deleted (in which case we do nothing.) ;;; ;;; Since this can get called during IR1 conversion, we have to be -;;; careful not to fly into space when the Dest's Prev is missing. +;;; careful not to fly into space when the DEST's PREV is missing. (defun reoptimize-continuation (cont) (declare (type continuation cont)) (unless (member (continuation-kind cont) '(:deleted :unused)) @@ -378,6 +378,7 @@ (derive-node-type node (continuation-derived-type value))))) (cset (ir1-optimize-set node))))) + (values)) ;;; Try to join with a successor block. If we succeed, we return true, @@ -1184,15 +1185,21 @@ (values)) ;;; Replace a call to a foldable function of constant arguments with -;;; the result of evaluating the form. We insert the resulting -;;; constant node after the call, stealing the call's continuation. We -;;; give the call a continuation with no DEST, which should cause it -;;; and its arguments to go away. If there is an error during the +;;; the result of evaluating the form. If there is an error during the ;;; evaluation, we give a warning and leave the call alone, making the ;;; call a :ERROR call. ;;; ;;; If there is more than one value, then we transform the call into a ;;; VALUES form. +;;; +;;; An old commentary also said: +;;; +;;; We insert the resulting constant node after the call, stealing +;;; the call's continuation. We give the call a continuation with no +;;; DEST, which should cause it and its arguments to go away. +;;; +;;; This seems to be more efficient, than the current code. Maybe we +;;; should really implement it? -- APD, 2002-12-23 (defun constant-fold-call (call) (let ((args (mapcar #'continuation-value (combination-args call))) (fun-name (combination-fun-source-name call))) @@ -1226,22 +1233,35 @@ ;; when the compiler tries to constant-fold (<= ;; END SIZE). ;; - ;; So, with or without bug 173, it'd be + ;; So, with or without bug 173, it'd be ;; unnecessarily evil to do a full ;; COMPILER-WARNING (and thus return FAILURE-P=T ;; from COMPILE-FILE) for legal code, so we we ;; use a wimpier COMPILE-STYLE-WARNING instead. #'compiler-style-warn "constant folding") - (if (not win) - (setf (combination-kind call) :error) - (let ((dummies (make-gensym-list (length args)))) - (transform-call - call - `(lambda ,dummies - (declare (ignore ,@dummies)) - (values ,@(mapcar (lambda (x) `',x) values))) - fun-name))))) + (cond ((not win) + (setf (combination-kind call) :error)) + ((and (proper-list-of-length-p values 1) + (eq (continuation-kind (node-cont call)) :inside-block)) + (with-ir1-environment-from-node call + (let* ((cont (node-cont call)) + (next (continuation-next cont)) + (prev (make-continuation))) + (delete-continuation-use call) + (add-continuation-use call prev) + (reference-constant prev cont (first values)) + (setf (continuation-next cont) next) + ;; FIXME: type checking? + (reoptimize-continuation cont) + (reoptimize-continuation prev)))) + (t (let ((dummies (make-gensym-list (length args)))) + (transform-call + call + `(lambda ,dummies + (declare (ignore ,@dummies)) + (values ,@(mapcar (lambda (x) `',x) values))) + fun-name)))))) (values)) ;;;; local call optimization @@ -1262,13 +1282,16 @@ (values)))) ;;; Figure out the type of a LET variable that has sets. We compute -;;; the union of the initial value Type and the types of all the set +;;; the union of the initial value TYPE and the types of all the set ;;; values and to a PROPAGATE-TO-REFS with this type. (defun propagate-from-sets (var type) (collect ((res type type-union)) (dolist (set (basic-var-sets var)) - (res (continuation-type (set-value set))) - (setf (node-reoptimize set) nil)) + (let ((type (continuation-type (set-value set)))) + (res type) + (when (node-reoptimize set) + (derive-node-type set type) + (setf (node-reoptimize set) nil)))) (propagate-to-refs var (res))) (values)) diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp index 8b1d32b..ff67c66 100644 --- a/src/compiler/node.lisp +++ b/src/compiler/node.lisp @@ -276,19 +276,9 @@ (flags (block-attributes reoptimize flush-p type-check type-asserted test-modified) :type attributes) - ;; CMU CL had a KILL slot here, documented as "set used by - ;; constraint propagation", which was used in constraint propagation - ;; as a list of LAMBDA-VARs killed, and in copy propagation as an - ;; SSET, representing I dunno what. I (WHN) found this confusing, - ;; and furthermore it caused type errors when I was trying to make - ;; the compiler produce fully general LAMBDA functions directly - ;; (instead of doing as CMU CL always did, producing extra little - ;; functions which return the LAMDBA you need) and therefore taking - ;; a new path through the compiler. So I split this into two: - ;; KILL-LIST = list of LAMBDA-VARs killed, used in constraint propagation - ;; KILL-SSET = an SSET value, used in copy propagation - (kill-list nil :type list) - (kill-sset nil :type (or sset null)) + ;; in constraint propagation: list of LAMBDA-VARs killed in this block + ;; in copy propagation: list of killed TNs + (kill nil) ;; other sets used in constraint propagation and/or copy propagation (gen nil) (in nil) @@ -306,8 +296,8 @@ (flag nil) ;; some kind of info used by the back end (info nil) - ;; If true, then constraints that hold in this block and its - ;; successors by merit of being tested by its IF predecessor. + ;; constraints that hold in this block and its successors by merit + ;; of being tested by its IF predecessors. (test-constraint nil :type (or sset null))) (def!method print-object ((cblock cblock) stream) (print-unreadable-object (cblock stream :type t :identity t) diff --git a/src/compiler/sset.lisp b/src/compiler/sset.lisp index 9106839..624fa08 100644 --- a/src/compiler/sset.lisp +++ b/src/compiler/sset.lisp @@ -73,6 +73,10 @@ (declare (inline member)) (not (null (member element (cdr (sset-elements set)) :test #'eq)))) +(declaim (ftype (function (sset sset) boolean) sset=)) +(defun sset= (set1 set2) + (equal (sset-elements set1) (sset-elements set2))) + ;;; Return true if SET contains no elements, false otherwise. (declaim (ftype (function (sset) boolean) sset-empty)) (defun sset-empty (set) @@ -152,7 +156,7 @@ (shiftf prev-el1 el1 (cdr el1)))))))) ;;; Destructively modify SET1 to include its union with the difference -;;; of SET2 and SET3. We return true if Set1 was modified, false +;;; of SET2 and SET3. We return true if SET1 was modified, false ;;; otherwise. (declaim (ftype (function (sset sset sset) boolean) sset-union-of-difference)) (defun sset-union-of-difference (set1 set2 set3) diff --git a/src/compiler/vop.lisp b/src/compiler/vop.lisp index 605bb4a..fca025a 100644 --- a/src/compiler/vop.lisp +++ b/src/compiler/vop.lisp @@ -897,7 +897,7 @@ ;; If a local TN, the block relative number for this TN. Global TNs ;; whose liveness changes within a block are also assigned a local ;; number during the conflicts analysis of that block. If the TN has - ;; no local number within the block, then this is Nil. + ;; no local number within the block, then this is NIL. (local-number nil :type (or local-tn-number null)) ;; If this object is a local TN, this slot is a bit-vector with 1 ;; for the local-number of every TN that we conflict with. diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 3d87d16..6080159 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -283,3 +283,12 @@ (function-lambda-expression (compile nil '(lambda (x) (block nil (print x))))) '(lambda (x) (block nil (print x))))) + +;;; bug 62: too cautious type inference in a loop +(assert (nth-value + 2 + (compile nil + '(lambda (a) + (declare (optimize speed (safety 0))) + (typecase a + (array (loop (print (car a))))))))) diff --git a/version.lisp-expr b/version.lisp-expr index b4b5b49..e7dabca 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.11.1" +"0.7.11.2" -- 1.7.10.4