1 ! Copyright (C) 2009 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators compiler.cfg
4 compiler.cfg.instructions compiler.cfg.parallel-copy
5 compiler.cfg.registers compiler.cfg.stacks.height
6 kernel make math math.order namespaces sequences sets ;
7 FROM: namespaces => set ;
8 IN: compiler.cfg.stacks.local
10 : >loc< ( loc -- n ds? )
11 [ n>> ] [ ds-loc? ] bi ;
13 : modify-height ( state loc -- )
14 >loc< 0 1 ? rot nth [ + ] with map! drop ;
16 : adjust ( state loc -- )
17 >loc< 0 1 ? rot nth dup first swapd + 0 rot set-nth ;
19 : reset-emits ( state -- )
20 [ 0 1 rot set-nth ] each ;
22 : height-state>insns ( state -- insns )
23 [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
24 [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
26 : translate-local-loc ( state loc -- loc' )
27 >loc< [ 0 1 ? rot nth first - ] keep ds-loc rs-loc ? new swap >>n ;
29 : clone-height-state ( state -- state' )
32 : initial-height-state ( -- state )
33 { { 0 0 } { 0 0 } } clone-height-state ;
35 : kill-locations ( saved-height height -- seq )
36 dupd [-] iota [ swap - ] with map ;
38 : local-kill-set ( ds-height rs-height state -- assoc )
39 first2 [ first ] bi@ swapd [ kill-locations ] 2bi@
40 [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
43 SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
45 : inc-stack ( loc -- )
46 height-state get swap modify-height ;
48 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
49 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
51 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
53 : stack-changes ( replace-mapping -- insns )
54 [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
58 replace-mapping get stack-changes %
59 height-state get height-state>insns %
62 : peek-loc ( loc -- vreg )
63 height-state get swap translate-local-loc
64 dup replace-mapping get at
65 [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
67 : replace-loc ( vreg loc -- )
68 height-state get swap translate-local-loc
69 replace-mapping get set-at ;
71 : compute-local-kill-set ( -- assoc )
72 basic-block get [ rs-heights get at ] [ ds-heights get at ] bi
73 height-state get local-kill-set ;
75 : begin-local-analysis ( -- )
76 H{ } clone local-peek-set set
77 H{ } clone replace-mapping set
80 first2 [ first ] bi@ basic-block get record-stack-heights
83 : remove-redundant-replaces ( -- )
84 replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
85 [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
87 : end-local-analysis ( -- )
88 remove-redundant-replaces
91 [ [ local-peek-set get ] dip peek-sets get set-at ]
92 [ [ local-replace-set get ] dip replace-sets get set-at ]
93 [ [ compute-local-kill-set ] dip kill-sets get set-at ]
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 ;