1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs kernel math math.order namespaces sets make
4 sequences combinators fry
7 compiler.cfg.instructions
9 compiler.cfg.stacks.height
10 compiler.cfg.parallel-copy ;
11 IN: compiler.cfg.stacks.local
13 ! Local stack analysis. We build three sets for every basic block
15 ! - peek-set: all stack locations that the block reads before writing
16 ! - replace-set: all stack locations that the block writes
17 ! - kill-set: all stack locations which become unavailable after the
18 ! block ends because of the stack height being decremented
19 ! This is done while constructing the CFG.
21 SYMBOLS: peek-sets replace-sets kill-sets ;
25 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
26 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
32 { emit-r initial: 0 } ;
34 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
36 GENERIC: translate-local-loc ( loc -- loc' )
37 M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
38 M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
40 : emit-stack-changes ( -- )
41 replace-mapping get dup assoc-empty? [ drop ] [
42 [ [ loc>vreg ] dip ] assoc-map parallel-copy
45 : emit-height-changes ( -- )
47 [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
48 [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
51 ! Insert height and stack changes prior to the last instruction
57 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
60 [ [ + ] change-emit-d drop ]
61 [ [ + ] change-d drop ]
66 [ [ + ] change-emit-r drop ]
67 [ [ + ] change-r drop ]
70 : peek-loc ( loc -- vreg )
72 dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
73 dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
75 : replace-loc ( vreg loc -- )
78 [ nip replace-mapping get delete-at ]
80 [ local-replace-set get conjoin ]
81 [ replace-mapping get set-at ]
85 : compute-local-kill-set ( -- assoc )
86 basic-block get current-height get
87 [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
88 [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
91 : begin-local-analysis ( -- )
92 H{ } clone local-peek-set set
93 H{ } clone local-replace-set set
94 H{ } clone replace-mapping set
96 [ 0 >>emit-d 0 >>emit-r drop ]
97 [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
99 : end-local-analysis ( -- )
102 [ [ local-peek-set get ] dip peek-sets get set-at ]
103 [ [ local-replace-set get ] dip replace-sets get set-at ]
104 [ [ compute-local-kill-set ] dip kill-sets get set-at ]
107 : clone-current-height ( -- )
108 current-height [ clone ] change ;
110 : peek-set ( bb -- assoc ) peek-sets get at ;
111 : replace-set ( bb -- assoc ) replace-sets get at ;
112 : kill-set ( bb -- assoc ) kill-sets get at ;