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
parent
7f9fbdaa4e
commit
5f4b247072
|
@ -40,8 +40,8 @@ M: #dispatch live-branches
|
||||||
SYMBOL: infer-children-data
|
SYMBOL: infer-children-data
|
||||||
|
|
||||||
: copy-value-info ( -- )
|
: copy-value-info ( -- )
|
||||||
value-infos [ clone ] change
|
value-infos [ H{ } clone suffix ] change
|
||||||
constraints [ clone ] change ;
|
constraints [ H{ } clone suffix ] change ;
|
||||||
|
|
||||||
: no-value-info ( -- )
|
: no-value-info ( -- )
|
||||||
value-infos off
|
value-infos off
|
||||||
|
|
|
@ -32,7 +32,7 @@ TUPLE: true-constraint value ;
|
||||||
|
|
||||||
M: true-constraint assume*
|
M: true-constraint assume*
|
||||||
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
[ \ f class-not <class-info> swap value>> refine-value-info ]
|
||||||
[ constraints get at [ assume ] when* ]
|
[ constraints get assoc-stack [ assume ] when* ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
M: true-constraint satisfied?
|
M: true-constraint satisfied?
|
||||||
|
@ -44,7 +44,7 @@ TUPLE: false-constraint value ;
|
||||||
|
|
||||||
M: false-constraint assume*
|
M: false-constraint assume*
|
||||||
[ \ f <class-info> swap value>> refine-value-info ]
|
[ \ f <class-info> swap value>> refine-value-info ]
|
||||||
[ constraints get at [ assume ] when* ]
|
[ constraints get assoc-stack [ assume ] when* ]
|
||||||
bi ;
|
bi ;
|
||||||
|
|
||||||
M: false-constraint satisfied?
|
M: false-constraint satisfied?
|
||||||
|
@ -83,7 +83,7 @@ TUPLE: implication p q ;
|
||||||
C: --> implication
|
C: --> implication
|
||||||
|
|
||||||
: assume-implication ( p q -- )
|
: 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 ;
|
[ satisfied? [ assume ] [ drop ] if ] 2bi ;
|
||||||
|
|
||||||
M: implication assume*
|
M: implication assume*
|
||||||
|
|
|
@ -262,17 +262,19 @@ DEFER: (value-info-union)
|
||||||
]
|
]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
! Current value --> info mapping
|
! Assoc stack of current value --> info mapping
|
||||||
SYMBOL: value-infos
|
SYMBOL: value-infos
|
||||||
|
|
||||||
: value-info ( value -- info )
|
: 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 -- )
|
: 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 -- )
|
: 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-literal ( value -- obj ? )
|
||||||
value-info >literal< ;
|
value-info >literal< ;
|
||||||
|
|
|
@ -8,7 +8,7 @@ math.functions math.private strings layouts
|
||||||
compiler.tree.propagation.info compiler.tree.def-use
|
compiler.tree.propagation.info compiler.tree.def-use
|
||||||
compiler.tree.debugger compiler.tree.checker
|
compiler.tree.debugger compiler.tree.checker
|
||||||
slots.private words hashtables classes assocs locals
|
slots.private words hashtables classes assocs locals
|
||||||
float-arrays system ;
|
float-arrays system sorting ;
|
||||||
IN: compiler.tree.propagation.tests
|
IN: compiler.tree.propagation.tests
|
||||||
|
|
||||||
\ propagate must-infer
|
\ propagate must-infer
|
||||||
|
@ -592,6 +592,8 @@ MIXIN: empty-mixin
|
||||||
|
|
||||||
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
|
[ V{ t } ] [ [ netbsd unix? ] final-literals ] unit-test
|
||||||
|
|
||||||
|
[ V{ array } ] [ [ [ <=> ] sort [ <=> ] sort ] final-classes ] unit-test
|
||||||
|
|
||||||
! [ V{ string } ] [
|
! [ V{ string } ] [
|
||||||
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
|
||||||
! ] unit-test
|
! ] unit-test
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! 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
|
||||||
compiler.tree.propagation.copy
|
compiler.tree.propagation.copy
|
||||||
compiler.tree.propagation.info
|
compiler.tree.propagation.info
|
||||||
|
@ -17,7 +17,7 @@ IN: compiler.tree.propagation
|
||||||
|
|
||||||
: propagate ( node -- node )
|
: propagate ( node -- node )
|
||||||
H{ } clone copies set
|
H{ } clone copies set
|
||||||
H{ } clone constraints set
|
H{ } clone 1array value-infos set
|
||||||
H{ } clone value-infos set
|
H{ } clone 1array constraints set
|
||||||
dup count-nodes
|
dup count-nodes
|
||||||
dup (propagate) ;
|
dup (propagate) ;
|
||||||
|
|
|
@ -17,9 +17,12 @@ IN: compiler.tree.propagation.recursive
|
||||||
[ value-info<= ] 2all?
|
[ value-info<= ] 2all?
|
||||||
[ drop ] [ label>> f >>fixed-point drop ] if ;
|
[ drop ] [ label>> f >>fixed-point drop ] if ;
|
||||||
|
|
||||||
|
: latest-input-infos ( node -- infos )
|
||||||
|
in-d>> [ value-info ] map ;
|
||||||
|
|
||||||
: recursive-stacks ( #enter-recursive -- stacks initial )
|
: recursive-stacks ( #enter-recursive -- stacks initial )
|
||||||
[ label>> calls>> [ node-input-infos ] map flip ]
|
[ label>> calls>> [ node-input-infos ] map flip ]
|
||||||
[ in-d>> [ value-info ] map ] bi ;
|
[ latest-input-infos ] bi ;
|
||||||
|
|
||||||
: generalize-counter-interval ( interval initial-interval -- interval' )
|
: generalize-counter-interval ( interval initial-interval -- interval' )
|
||||||
{
|
{
|
||||||
|
@ -46,14 +49,13 @@ IN: compiler.tree.propagation.recursive
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: propagate-recursive-phi ( #enter-recursive -- )
|
: propagate-recursive-phi ( #enter-recursive -- )
|
||||||
[ ] [ recursive-stacks unify-recursive-stacks ] [ ] tri
|
[ recursive-stacks unify-recursive-stacks ] keep
|
||||||
[ node-output-infos check-fixed-point ]
|
out-d>> set-value-infos ;
|
||||||
[ out-d>> set-value-infos drop ]
|
|
||||||
3bi ;
|
|
||||||
|
|
||||||
M: #recursive propagate-around ( #recursive -- )
|
M: #recursive propagate-around ( #recursive -- )
|
||||||
|
constraints [ H{ } clone suffix ] change
|
||||||
[
|
[
|
||||||
constraints [ clone ] change
|
constraints [ but-last H{ } clone suffix ] change
|
||||||
|
|
||||||
child>>
|
child>>
|
||||||
[ first compute-copy-equiv ]
|
[ first compute-copy-equiv ]
|
||||||
|
@ -62,6 +64,9 @@ M: #recursive propagate-around ( #recursive -- )
|
||||||
tri
|
tri
|
||||||
] until-fixed-point ;
|
] until-fixed-point ;
|
||||||
|
|
||||||
|
: recursive-phi-infos ( node -- infos )
|
||||||
|
label>> enter-recursive>> node-output-infos ;
|
||||||
|
|
||||||
: generalize-return-interval ( info -- info' )
|
: generalize-return-interval ( info -- info' )
|
||||||
dup [ literal?>> ] [ class>> null-class? ] bi or
|
dup [ literal?>> ] [ class>> null-class? ] bi or
|
||||||
[ clone [-inf,inf] >>interval ] unless ;
|
[ clone [-inf,inf] >>interval ] unless ;
|
||||||
|
@ -70,12 +75,22 @@ M: #recursive propagate-around ( #recursive -- )
|
||||||
[ generalize-return-interval ] map ;
|
[ generalize-return-interval ] map ;
|
||||||
|
|
||||||
: return-infos ( node -- infos )
|
: return-infos ( node -- infos )
|
||||||
label>> [ return>> node-input-infos ] [ loop?>> ] bi
|
label>> return>> node-input-infos generalize-return ;
|
||||||
[ generalize-return ] unless ;
|
|
||||||
|
: save-return-infos ( node infos -- )
|
||||||
|
swap out-d>> set-value-infos ;
|
||||||
|
|
||||||
M: #call-recursive propagate-before ( #call-recursive -- )
|
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
|
M: #call-recursive annotate-node
|
||||||
dup [ in-d>> ] [ out-d>> ] bi append (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
|
M: #enter-recursive annotate-node
|
||||||
dup out-d>> (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
|
M: #return-recursive annotate-node
|
||||||
dup in-d>> (annotate-node) ;
|
dup in-d>> (annotate-node) ;
|
||||||
|
|
Loading…
Reference in New Issue