From 5f4b2470722b3d4a709aba84be0d7178c781713f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 11 Nov 2008 08:49:00 -0600 Subject: [PATCH] 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 --- .../tree/propagation/branches/branches.factor | 4 +- .../constraints/constraints.factor | 6 +-- .../tree/propagation/info/info.factor | 10 +++-- .../tree/propagation/propagation-tests.factor | 4 +- .../tree/propagation/propagation.factor | 6 +-- .../propagation/recursive/recursive.factor | 41 ++++++++++++++----- 6 files changed, 48 insertions(+), 23 deletions(-) diff --git a/basis/compiler/tree/propagation/branches/branches.factor b/basis/compiler/tree/propagation/branches/branches.factor index c76217f8ae..424cd8a01c 100644 --- a/basis/compiler/tree/propagation/branches/branches.factor +++ b/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 diff --git a/basis/compiler/tree/propagation/constraints/constraints.factor b/basis/compiler/tree/propagation/constraints/constraints.factor index cfdf7f5169..2652547aad 100644 --- a/basis/compiler/tree/propagation/constraints/constraints.factor +++ b/basis/compiler/tree/propagation/constraints/constraints.factor @@ -32,7 +32,7 @@ TUPLE: true-constraint value ; M: true-constraint assume* [ \ f class-not 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 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* diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor index 11111fd11e..e89a9c6211 100644 --- a/basis/compiler/tree/propagation/info/info.factor +++ b/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< ; diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor index 101320f92c..760ff167aa 100644 --- a/basis/compiler/tree/propagation/propagation-tests.factor +++ b/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 diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor index d82ebed433..b9822d2c6b 100644 --- a/basis/compiler/tree/propagation/propagation.factor +++ b/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) ; diff --git a/basis/compiler/tree/propagation/recursive/recursive.factor b/basis/compiler/tree/propagation/recursive/recursive.factor index 53dce813a3..70cda11d3d 100644 --- a/basis/compiler/tree/propagation/recursive/recursive.factor +++ b/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) ;