! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sets make sequences
+USING: accessors assocs kernel math math.order namespaces sets make
+sequences combinators fry
compiler.cfg
compiler.cfg.hats
compiler.cfg.instructions
! Local stack analysis. We build local peek and replace sets for every basic
! block while constructing the CFG.
-SYMBOLS: peek-sets replace-sets ;
+SYMBOLS: peek-sets replace-sets kill-sets ;
SYMBOL: locs>vregs
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
-TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+TUPLE: current-height
+{ d initial: 0 }
+{ r initial: 0 }
+{ emit-d initial: 0 }
+{ emit-r initial: 0 } ;
SYMBOLS: local-peek-set local-replace-set replace-mapping ;
bi
] if ;
+: compute-local-kill-set ( -- assoc )
+ basic-block get current-height get
+ [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
+ [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ]
+ [ drop local-replace-set get at ] 2tri
+ [ append unique dup ] dip update ;
+
: begin-local-analysis ( -- )
H{ } clone local-peek-set set
H{ } clone local-replace-set set
H{ } clone replace-mapping set
- current-height get 0 >>emit-d 0 >>emit-r drop
- current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
+ current-height get
+ [ 0 >>emit-d 0 >>emit-r drop ]
+ [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
: end-local-analysis ( -- )
emit-changes
- local-peek-set get basic-block get peek-sets get set-at
- local-replace-set get basic-block get replace-sets get set-at ;
+ basic-block get {
+ [ [ local-peek-set get ] dip peek-sets get set-at ]
+ [ [ local-replace-set get ] dip replace-sets get set-at ]
+ [ [ compute-local-kill-set ] dip kill-sets get set-at ]
+ } cleave ;
: clone-current-height ( -- )
current-height [ clone ] change ;
: peek-set ( bb -- assoc ) peek-sets get at ;
: replace-set ( bb -- assoc ) replace-sets get at ;
+: kill-set ( bb -- assoc ) kill-sets get at ;
\ No newline at end of file