Propagation pass now uses a stack of hashtables for predicated constraints instead of cloning a hashtable. New strategy for recursive propagation; now converges with fewer iterations. ~15 sec bootstrap time improvement

basis/compiler/tree/propagation/branches/branches.factor

@@ -40,8 +40,8 @@ M: #dispatch live-branches
 SYMBOL: infer-children-data
 
 : copy-value-info ( -- )
-    value-infos [ clone ] change
-    constraints [ clone ] change ;
+    value-infos [ H{ } clone suffix ] change
+    constraints [ H{ } clone suffix ] change ;
 
 : no-value-info ( -- )
     value-infos off

basis/compiler/tree/propagation/constraints/constraints.factor

@@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
 
 M: true-constraint assume*
     [ \ f class-not <class-info> swap value>> refine-value-info ]
-    [ constraints get at [ assume ] when* ]
+    [ constraints get assoc-stack [ assume ] when* ]
     bi ;
 
 M: true-constraint satisfied?
@@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
 
 M: false-constraint assume*
     [ \ f <class-info> swap value>> refine-value-info ]
-    [ constraints get at [ assume ] when* ]
+    [ constraints get assoc-stack [ assume ] when* ]
     bi ;
 
 M: false-constraint satisfied?
@@ -83,7 +83,7 @@ TUPLE: implication p q ;
 C: --> implication
 
 : assume-implication ( p q -- )
-    [ constraints get [ swap suffix ] change-at ]
+    [ constraints get [ assoc-stack swap suffix ] 2keep peek set-at ]
     [ satisfied? [ assume ] [ drop ] if ] 2bi ;
 
 M: implication assume*

basis/compiler/tree/propagation/info/info.factor

@@ -262,17 +262,19 @@ DEFER: (value-info-union)
         ]
     } cond ;
 
-! Current value --> info mapping
+! Assoc stack of current value --> info mapping
 SYMBOL: value-infos
 
 : value-info ( value -- info )
-    resolve-copy value-infos get at null-info or ;
+    resolve-copy value-infos get assoc-stack null-info or ;
 
 : set-value-info ( info value -- )
-    resolve-copy value-infos get set-at ;
+    resolve-copy value-infos get peek set-at ;
 
 : refine-value-info ( info value -- )
-    resolve-copy value-infos get [ value-info-intersect ] change-at ;
+    resolve-copy value-infos get
+    [ assoc-stack value-info-intersect ] 2keep
+    peek set-at ;
 
 : value-literal ( value -- obj ? )
     value-info >literal< ;

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

@@ -8,7 +8,7 @@ math.functions math.private strings layouts
 compiler.tree.propagation.info compiler.tree.def-use
 compiler.tree.debugger compiler.tree.checker
 slots.private words hashtables classes assocs locals
-float-arrays system ;
+float-arrays system sorting ;
 IN: compiler.tree.propagation.tests
 
 \ propagate must-infer
@@ -592,6 +592,8 @@ MIXIN: empty-mixin
 
 [ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
 
+[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/propagation/propagation.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel sequences namespaces hashtables
+USING: accessors kernel sequences namespaces hashtables arrays
 compiler.tree
 compiler.tree.propagation.copy
 compiler.tree.propagation.info
@@ -17,7 +17,7 @@ IN: compiler.tree.propagation
 
 : propagate ( node -- node )
     H{ } clone copies set
-    H{ } clone constraints set
-    H{ } clone value-infos set
+    H{ } clone 1array value-infos set
+    H{ } clone 1array constraints set
     dup count-nodes
     dup (propagate) ;

basis/compiler/tree/propagation/recursive/recursive.factor

@@ -17,9 +17,12 @@ IN: compiler.tree.propagation.recursive
     [ value-info<= ] 2all?
     [ drop ] [ label>> f >>fixed-point drop ] if ;
 
+: latest-input-infos ( node -- infos )
+    in-d>> [ value-info ] map ;
+
 : recursive-stacks ( #enter-recursive -- stacks initial )
     [ label>> calls>> [ node-input-infos ] map flip ]
-    [ in-d>> [ value-info ] map ] bi ;
+    [ latest-input-infos ] bi ;
 
 : generalize-counter-interval ( interval initial-interval -- interval' )
     {
@@ -46,14 +49,13 @@ IN: compiler.tree.propagation.recursive
     ] if ;
 
 : propagate-recursive-phi ( #enter-recursive -- )
-    [ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
-    [ node-output-infos check-fixed-point ]
-    [ out-d>> set-value-infos drop ]
-    3bi ;
+    [ recursive-stacks unify-recursive-stacks ] keep
+    out-d>> set-value-infos ;
 
 M: #recursive propagate-around ( #recursive -- )
+    constraints [ H{ } clone suffix ] change
     [
-        constraints [ clone ] change
+        constraints [ but-last H{ } clone suffix ] change
 
         child>>
         [ first compute-copy-equiv ]
@@ -62,6 +64,9 @@ M: #recursive propagate-around ( #recursive -- )
         tri
     ] until-fixed-point ;
 
+: recursive-phi-infos ( node -- infos )
+    label>> enter-recursive>> node-output-infos ;
+
 : generalize-return-interval ( info -- info' )
     dup [ literal?>> ] [ class>> null-class? ] bi or
     [ clone [-inf,inf] >>interval ] unless ;
@@ -70,12 +75,22 @@ M: #recursive propagate-around ( #recursive -- )
     [ generalize-return-interval ] map ;
 
 : return-infos ( node -- infos )
-    label>> [ return>> node-input-infos ] [ loop?>> ] bi
-    [ generalize-return ] unless ;
+    label>> return>> node-input-infos generalize-return ;
+
+: save-return-infos ( node infos -- )
+    swap out-d>> set-value-infos ;
 
 M: #call-recursive propagate-before ( #call-recursive -- )
-    [ ] [ return-infos ] [ node-output-infos ] tri
-    [ check-fixed-point ] [ drop swap out-d>> set-value-infos ] 3bi ;
+    [
+        [ ] [ latest-input-infos ] [ recursive-phi-infos ] tri
+        check-fixed-point
+    ]
+    [
+        dup label>> loop?>> [ drop ] [
+            [ ] [ return-infos ] [ node-output-infos ] tri
+            [ check-fixed-point ] [ drop save-return-infos ] 3bi
+        ] if
+    ] bi ;
 
 M: #call-recursive annotate-node
     dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
@@ -83,5 +98,11 @@ M: #call-recursive annotate-node
 M: #enter-recursive annotate-node
     dup out-d>> (annotate-node) ;
 
+M: #return-recursive propagate-before ( #return-recursive -- )
+    dup label>> loop?>> [ drop ] [
+        [ ] [ latest-input-infos ] [ node-input-infos ] tri
+        check-fixed-point
+    ] if ;
+
 M: #return-recursive annotate-node
     dup in-d>> (annotate-node) ;