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 hash-sets kernel make math math.order namespaces sequences sets ;
7 FROM: namespaces => set ;
8 IN: compiler.cfg.stacks.local
10 : current-height ( state -- ds rs )
11 first2 [ first ] bi@ ;
13 : >loc< ( loc -- n ds? )
14 [ n>> ] [ ds-loc? ] bi ;
16 : modify-height ( state loc -- )
17 >loc< 0 1 ? rot nth [ + ] with map! drop ;
19 : adjust ( state loc -- )
20 >loc< 0 1 ? rot nth dup first swapd + 0 rot set-nth ;
22 : reset-emits ( state -- )
23 [ 0 1 rot set-nth ] each ;
25 : height-state>insns ( state -- insns )
26 [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
27 [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
29 : translate-local-loc ( loc state -- loc' )
30 [ clone ] dip over >loc< 0 1 ? rot nth first - >>n ;
32 : clone-height-state ( state -- state' )
35 : initial-height-state ( -- state )
36 { { 0 0 } { 0 0 } } clone-height-state ;
38 : kill-locations ( saved-height height -- seq )
39 dupd [-] iota [ swap - ] with map ;
41 : local-kill-set ( ds-height rs-height state -- set )
42 current-height swapd [ kill-locations ] 2bi@
43 [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
46 SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
48 : inc-stack ( loc -- )
49 height-state get swap modify-height ;
51 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
52 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
54 SYMBOLS: local-peek-set replaces ;
56 : replaces>copy-insns ( replaces -- insns )
57 [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
59 : changes>insns ( replaces height-state -- insns )
60 [ replaces>copy-insns ] [ height-state>insns ] bi* append ;
62 : emit-changes ( replaces height-state -- )
63 building get pop -rot changes>insns % , ;
65 : peek-loc ( loc -- vreg )
66 height-state get translate-local-loc dup replaces get at
67 [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
69 : replace-loc ( vreg loc -- )
70 height-state get translate-local-loc replaces get set-at ;
72 : compute-local-kill-set ( basic-block -- set )
73 [ rs-heights get at ] [ ds-heights get at ] bi
74 height-state get local-kill-set ;
76 : begin-local-analysis ( basic-block -- )
77 height-state get dup reset-emits
78 current-height rot record-stack-heights
79 HS{ } clone local-peek-set set
80 H{ } clone replaces set ;
82 : remove-redundant-replaces ( replaces -- replaces' )
83 [ [ loc>vreg ] dip = not ] assoc-filter ;
85 : end-local-analysis ( basic-block -- )
87 replaces get remove-redundant-replaces
88 dup height-state get emit-changes keys
89 swap replace-sets get set-at
91 [ [ local-peek-set get ] dip peek-sets get set-at ]
92 [ [ compute-local-kill-set ] keep kill-sets get set-at ] tri ;