From 4fdb5d05576c326b13f3a189fdfc7348573505bf Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Mar 2009 17:30:24 -0500 Subject: [PATCH 1/3] Fix infinite fixed point iteration bug found by littledan; generalize-counter-interval wasn't called in all the right places --- .../tree/propagation/info/info.factor | 2 +- .../tree/propagation/propagation-tests.factor | 33 +++++++++++++++++++ .../propagation/recursive/recursive.factor | 11 +++++-- 3 files changed, 42 insertions(+), 4 deletions(-) diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 7b1723620b..c56db570b2 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/basis/compiler/tree/propagation/info/info.factor @@ -238,7 +238,7 @@ DEFER: (value-info-union) : value-infos-union ( infos -- info ) [ null-info ] - [ dup first [ value-info-union ] reduce ] if-empty ; + [ unclip-slice [ value-info-union ] reduce ] if-empty ; : literals<= ( info1 info2 -- ? ) { diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 52ae83eb12..5dd647ae89 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/basis/compiler/tree/propagation/propagation-tests.factor @@ -655,3 +655,36 @@ MIXIN: empty-mixin ! [ t ] [ [ dup t xor and ] final-classes first false-class? ] unit-test ! [ t ] [ [ dup t xor swap and ] final-classes first false-class? ] unit-test + +! generalize-counter-interval wasn't being called in all the right places. +! bug found by littledan + +TUPLE: littledan-1 { a read-only } ; + +: (littledan-1-test) ( a -- ) a>> 1+ littledan-1 boa (littledan-1-test) ; inline recursive + +: littledan-1-test ( -- ) 0 littledan-1 boa (littledan-1-test) ; inline + +[ ] [ [ littledan-1-test ] final-classes drop ] unit-test + +TUPLE: littledan-2 { from read-only } { to read-only } ; + +: (littledan-2-test) ( x -- i elt ) + [ from>> ] [ to>> ] bi + dup littledan-2 boa (littledan-2-test) ; inline recursive + +: littledan-2-test ( x -- i elt ) + [ 0 ] dip { array-capacity } declare littledan-2 boa (littledan-2-test) ; inline + +[ ] [ [ littledan-2-test ] final-classes drop ] unit-test + +: (littledan-3-test) ( x -- ) + length 1+ f (littledan-3-test) ; inline recursive + +: littledan-3-test ( x -- ) + 0 f (littledan-3-test) ; inline + +[ ] [ [ littledan-3-test ] final-classes drop ] unit-test + +[ V{ 0 } ] [ [ { } length ] final-literals ] unit-test + +[ V{ 1 } ] [ [ { } length 1+ f length ] final-literals ] unit-test \ No newline at end of file diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index ff9f262d28..1bcd36f6b0 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/basis/compiler/tree/propagation/recursive/recursive.factor @@ -34,9 +34,14 @@ IN: compiler.tree.propagation.recursive } cond interval-union nip ; : generalize-counter ( info' initial -- info ) - 2dup [ class>> null-class? ] either? [ drop ] [ - [ drop clone ] [ [ interval>> ] bi@ ] 2bi - generalize-counter-interval >>interval + 2dup [ not ] either? [ drop ] [ + 2dup [ class>> null-class? ] either? [ drop ] [ + [ clone ] dip + [ [ drop ] [ [ interval>> ] bi@ generalize-counter-interval ] 2bi >>interval ] + [ [ drop ] [ [ slots>> ] bi@ [ generalize-counter ] 2map ] 2bi >>slots ] + [ [ drop ] [ [ length>> ] bi@ generalize-counter ] 2bi >>length ] + tri + ] if ] if ; : unify-recursive-stacks ( stacks initial -- infos ) From 80e719ba5bf3746ce505e616432f4823256d6bb5 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Mar 2009 17:30:33 -0500 Subject: [PATCH 2/3] Remove stupid commented out code --- basis/compiler/tree/finalization/finalization.factor | 3 --- 1 file changed, 3 deletions(-) diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor index ecd5429baf..0e72deb6fa 100644 --- a/basis/compiler/tree/finalization/finalization.factor +++ b/basis/compiler/tree/finalization/finalization.factor @@ -46,9 +46,6 @@ M: predicate finalize-word [ drop ] } cond ; -! M: math-partial finalize-word -! dup primitive? [ drop ] [ nip cached-expansion ] if ; - M: word finalize-word drop ; M: #call finalize* From 2f85a1a9ebf418c596c017d3d9ca5074b3b59732 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 12 Mar 2009 17:30:41 -0500 Subject: [PATCH 3/3] Don't report inference warnings for inline words --- basis/compiler/compiler.factor | 21 ++++++++++++--------- 1 file changed, 12 insertions(+), 9 deletions(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index d6da95408d..24ce3debeb 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -1,15 +1,14 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry -continuations vocabs assocs dlists definitions math graphs -generic combinators deques search-deques io stack-checker -stack-checker.state stack-checker.inlining -combinators.short-circuit compiler.errors compiler.units -compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer +continuations vocabs assocs dlists definitions math graphs generic +combinators deques search-deques macros io stack-checker +stack-checker.state stack-checker.inlining combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization compiler.cfg.two-operand -compiler.cfg.linear-scan compiler.cfg.stack-frame -compiler.codegen compiler.utilities ; +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -50,8 +49,12 @@ SYMBOLS: +optimized+ +unoptimized+ ; H{ } clone generic-dependencies set f swap compiler-error ; +: ignore-error? ( word error -- ? ) + [ [ inline? ] [ macro? ] bi or ] + [ compiler-error-type +warning+ eq? ] bi* and ; + : fail ( word error -- * ) - [ swap compiler-error ] + [ 2dup ignore-error? [ 2drop ] [ swap compiler-error ] if ] [ drop [ compiled-unxref ]