1 ! Copyright (C) 2009 Slava Pestov.
2 ! See https://factorcode.org/license.txt for BSD license.
3 USING: accessors arrays assocs combinators
4 compiler.cfg.instructions compiler.cfg.parallel-copy
5 compiler.cfg.registers hash-sets kernel make math math.order
6 namespaces sequences sets ;
7 IN: compiler.cfg.stacks.local
9 TUPLE: height-state ds-begin rs-begin ds-inc rs-inc ;
11 : >loc< ( loc -- n ds? )
12 [ n>> ] [ ds-loc? ] bi ;
14 : ds-height ( height-state -- n )
15 [ ds-begin>> ] [ ds-inc>> ] bi + ;
17 : rs-height ( height-state -- n )
18 [ rs-begin>> ] [ rs-inc>> ] bi + ;
20 : global-loc>local ( loc height-state -- loc' )
21 [ clone dup >loc< ] dip swap [ ds-height ] [ rs-height ] if - >>n ;
23 : local-loc>global ( loc height-state -- loc' )
24 [ clone dup >loc< ] dip swap [ ds-begin>> ] [ rs-begin>> ] if + >>n ;
26 : inc-stack ( loc -- )
27 >loc< height-state get swap
28 [ [ + ] change-ds-inc ] [ [ + ] change-rs-inc ] if drop ;
30 : height-state>insns ( height-state -- insns )
31 [ ds-inc>> ds-loc ] [ rs-inc>> rs-loc ] bi [ new swap >>n ] 2bi@ 2array
32 [ n>> 0 = ] reject [ ##inc new swap >>loc ] map ;
34 : reset-incs ( height-state -- )
35 dup ds-inc>> '[ _ + ] change-ds-begin
36 dup rs-inc>> '[ _ + ] change-rs-begin
37 0 >>ds-inc 0 >>rs-inc drop ;
39 SYMBOLS: locs>vregs local-peek-set replaces ;
41 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
42 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
44 : replaces>copy-insns ( replaces -- insns )
45 [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
47 : changes>insns ( replaces height-state -- insns )
48 [ replaces>copy-insns ] [ height-state>insns ] bi* append ;
50 : emit-insns ( replaces state -- )
51 building get pop -rot changes>insns % , ;
53 : peek-loc ( loc -- vreg )
54 height-state get global-loc>local
56 [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
58 : replace-loc ( vreg loc -- )
59 height-state get global-loc>local replaces get set-at ;
61 : kill-locations ( begin inc -- seq )
62 0 min neg <iota> [ swap - ] with map ;
64 : local-kill-set ( ds-begin ds-inc rs-begin rs-inc -- set )
65 [ kill-locations ] 2bi@
66 [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
69 : compute-local-kill-set ( height-state -- set )
70 { [ ds-begin>> ] [ ds-inc>> ] [ rs-begin>> ] [ rs-inc>> ] } cleave
73 : begin-local-analysis ( basic-block -- )
74 height-state [ clone ] change
75 height-state get [ reset-incs ] keep >>height drop
76 HS{ } clone local-peek-set namespaces:set
77 H{ } clone replaces namespaces:set ;
79 : remove-redundant-replaces ( replaces -- replaces' )
80 [ [ loc>vreg ] dip = ] assoc-reject ;
82 : end-local-analysis ( basic-block -- )
83 replaces get remove-redundant-replaces
85 [ height-state get emit-insns ] keep
87 keys >hash-set >>replaces
88 local-peek-set get >>peeks
89 height-state get compute-local-kill-set >>kills drop ;