1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors assocs combinators compiler.cfg
4 compiler.cfg.instructions compiler.cfg.parallel-copy
5 compiler.cfg.registers compiler.cfg.stacks.height kernel make
6 math math.order namespaces sequences sets ;
7 FROM: namespaces => set ;
8 IN: compiler.cfg.stacks.local
10 SYMBOLS: peek-sets replace-sets kill-sets ;
14 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
15 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
21 { emit-r initial: 0 } ;
23 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
25 GENERIC: translate-local-loc ( loc -- loc' )
26 M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
27 M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
29 : emit-stack-changes ( -- )
30 replace-mapping get dup assoc-empty? [ drop ] [
31 [ [ loc>vreg ] dip ] assoc-map parallel-copy
34 : emit-height-changes ( -- )
36 [ emit-d>> dup 0 = [ drop ] [ ##inc-d, ] if ]
37 [ emit-r>> dup 0 = [ drop ] [ ##inc-r, ] if ] bi ;
40 ! Insert height and stack changes prior to the last instruction
46 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
49 [ [ + ] change-emit-d drop ]
50 [ [ + ] change-d drop ]
55 [ [ + ] change-emit-r drop ]
56 [ [ + ] change-r drop ]
59 : peek-loc ( loc -- vreg )
61 dup replace-mapping get at
62 [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
64 : replace-loc ( vreg loc -- )
65 translate-local-loc replace-mapping get set-at ;
67 : compute-local-kill-set ( -- assoc )
68 basic-block get current-height get
69 [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
70 [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
73 : begin-local-analysis ( -- )
74 H{ } clone local-peek-set set
75 H{ } clone replace-mapping set
77 [ 0 >>emit-d 0 >>emit-r drop ]
78 [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
80 : remove-redundant-replaces ( -- )
81 replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
82 [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
84 : end-local-analysis ( -- )
85 remove-redundant-replaces
88 [ [ local-peek-set get ] dip peek-sets get set-at ]
89 [ [ local-replace-set get ] dip replace-sets get set-at ]
90 [ [ compute-local-kill-set ] dip kill-sets get set-at ]
93 : clone-current-height ( -- )
94 current-height [ clone ] change ;
96 : peek-set ( bb -- assoc ) peek-sets get at ;
97 : replace-set ( bb -- assoc ) replace-sets get at ;
98 : kill-set ( bb -- assoc ) kill-sets get at ;