More debugging

unfinished/compiler/tree/cleanup/cleanup-tests.factor

@@ -195,17 +195,17 @@ GENERIC: annotate-entry-test-1 ( x -- )
 
 M: fixnum annotate-entry-test-1 drop ;
 
-: (annotate-entry-test-2) ( from to quot: ( -- ) -- )
+: (annotate-entry-test-2) ( from to -- )
-    2over >= [
+    2dup >= [
-        3drop
+        2drop
     ] [
-        [ swap >r call dup annotate-entry-test-1 1+ r> ] keep (annotate-entry-test-2)
+        >r dup annotate-entry-test-1 1+ r> (annotate-entry-test-2)
     ] if ; inline recursive
 
 : annotate-entry-test-2 0 -rot (annotate-entry-test-2) ; inline
 
 [ f ] [
-    [ { bignum } declare [ ] annotate-entry-test-2 ]
+    [ { bignum } declare annotate-entry-test-2 ]
     \ annotate-entry-test-1 inlined?
 ] unit-test
 
@@ -375,7 +375,7 @@ cell-bits 32 = [
 
 [ t ] [
     [ { fixnum } declare 0 [ + ] reduce ]
-    { < <-integer-fixnum } inlined?
+    { < <-integer-fixnum nth-unsafe } inlined?
 ] unit-test
 
 [ f ] [

unfinished/compiler/tree/cleanup/cleanup.factor

@@ -22,7 +22,8 @@ GENERIC: cleanup* ( node -- node/nodes )
     [ cleanup* ] map flatten ;
 
 : cleanup-folding? ( #call -- ? )
-    node-output-infos [ literal?>> ] all? ;
+    node-output-infos dup empty?
+    [ drop f ] [ [ literal?>> ] all? ] if ;
 
 : cleanup-folding ( #call -- nodes )
     #! Replace a #call having a known result with a #drop of its

unfinished/compiler/tree/propagation/propagation-tests.factor

@@ -520,3 +520,11 @@ M: array iterate first t ;
 [ V{ POSTPONE: f } ] [
     [ 3 string? ] final-classes
 ] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum } declare [ ] curry obj>> ] final-classes
+] unit-test
+
+[ V{ fixnum } ] [
+    [ { fixnum fixnum } declare [ nth-unsafe ] curry call ] final-classes
+] unit-test

unfinished/compiler/tree/propagation/recursive/recursive-tests.factor

@@ -0,0 +1,19 @@
+IN: compiler.tree.propagation.recursive.tests
+USING: tools.test compiler.tree.propagation.recursive
+math.intervals kernel ;
+
+[ T{ interval f { 0 t } { 1/0. t } } ] [
+    T{ interval f { 1 t } { 1 t } }
+    T{ interval f { 0 t } { 0 t } } generalize-counter-interval
+] unit-test
+
+[ T{ interval f { -1/0. t } { 10 t } } ] [
+    T{ interval f { -1 t } { -1 t } }
+    T{ interval f { 10 t } { 10 t } } generalize-counter-interval
+] unit-test
+
+[ t ] [
+    T{ interval f { 1 t } { 268435455 t } }
+    T{ interval f { -268435456 t } { 268435455 t } } tuck
+    generalize-counter-interval =
+] unit-test

unfinished/compiler/tree/propagation/recursive/recursive.factor

@@ -21,12 +21,12 @@ IN: compiler.tree.propagation.recursive
 
 : generalize-counter-interval ( interval initial-interval -- interval' )
     {
-        { [ 2dup = ] [ empty-interval ] }
+        { [ 2dup interval-subset? ] [ empty-interval ] }
         { [ over empty-interval eq? ] [ empty-interval ] }
         { [ 2dup interval>= t eq? ] [ 1./0. [a,a] ] }
         { [ 2dup interval<= t eq? ] [ -1./0. [a,a] ] }
         [ [-inf,inf] ]
-    } cond nip interval-union ;
+    } cond interval-union nip ;
 
 : generalize-counter ( info' initial -- info )
     2dup [ class>> null-class? ] either? [ drop ] [

unfinished/compiler/tree/propagation/slots/slots.factor

@@ -29,7 +29,7 @@ UNION: fixed-length-sequence array byte-array string ;
     bi* value-info-intersect 1array ;
 
 : tuple-constructor? ( word -- ? )
-    { <tuple-boa> <complex> } memq? ;
+    { <tuple-boa> curry compose <complex> } memq? ;
 
 : read-only-slots ( values class -- slots )
     #! Delegation.
@@ -41,22 +41,33 @@ UNION: fixed-length-sequence array byte-array string ;
     [ , f , [ literal>> ] map % ] { } make >tuple
     <literal-info> ;
 
-: propagate-<tuple-boa> ( #call -- info )
+: (propagate-tuple-constructor) ( values class -- info )
-    #! Delegation
+    [ [ value-info ] map ] dip [ read-only-slots ] keep
-    in-d>> [ value-info ] map unclip-last
-    literal>> class>> [ read-only-slots ] keep
     over 2 tail-slice [ dup [ literal?>> ] when ] all? [
         [ 2 tail-slice ] dip fold-<tuple-boa>
     ] [
         <tuple-info>
     ] if ;
 
+: propagate-<tuple-boa> ( #call -- info )
+    #! Delegation
+    in-d>> unclip-last
+    value-info literal>> class>> (propagate-tuple-constructor) ;
+
+: propagate-curry ( #call -- info )
+    in-d>> \ curry (propagate-tuple-constructor) ;
+
+: propagate-compose ( #call -- info )
+    in-d>> \ compose (propagate-tuple-constructor) ;
+
 : propagate-<complex> ( #call -- info )
     in-d>> [ value-info ] map complex <tuple-info> ;
 
 : propagate-tuple-constructor ( #call word -- infos )
     {
         { \ <tuple-boa> [ propagate-<tuple-boa> ] }
+        { \ curry [ propagate-curry ] }
+        { \ compose [ propagate-compose ] } 
         { \ <complex> [ propagate-<complex> ] }
     } case 1array ;
 

unfinished/stack-checker/stack-checker-tests.factor

@@ -6,7 +6,7 @@ quotations effects tools.test continuations generic.standard
 sorting assocs definitions prettyprint io inspector
 classes.tuple classes.union classes.predicate debugger
 threads.private io.streams.string io.timeouts io.thread
-sequences.private destructors combinators ;
+sequences.private destructors combinators eval ;
 IN: stack-checker.tests
 
 : short-effect ( effect -- pair )