USING: accessors arrays assocs combinators compiler.cfg
compiler.cfg.instructions compiler.cfg.parallel-copy
compiler.cfg.registers compiler.cfg.stacks.height
-kernel make math math.order namespaces sequences sets ;
+fry hash-sets kernel make math math.order namespaces sequences sets ;
FROM: namespaces => set ;
IN: compiler.cfg.stacks.local
+: current-height ( state -- ds rs )
+ first2 [ first ] bi@ ;
+
: >loc< ( loc -- n ds? )
[ n>> ] [ ds-loc? ] bi ;
: height-state>insns ( state -- insns )
[ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
- [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
+ [ n>> 0 = ] reject [ ##inc new swap >>loc ] map ;
-: translate-local-loc ( state loc -- loc' )
- >loc< [ 0 1 ? rot nth first - ] keep ds-loc rs-loc ? new swap >>n ;
+: translate-local-loc ( loc state -- loc' )
+ [ clone ] dip over >loc< 0 1 ? rot nth first - >>n ;
: clone-height-state ( state -- state' )
[ clone ] map ;
: kill-locations ( saved-height height -- seq )
dupd [-] iota [ swap - ] with map ;
-: local-kill-set ( ds-height rs-height state -- assoc )
- first2 [ first ] bi@ swapd [ kill-locations ] 2bi@
+: local-kill-set ( ds-height rs-height state -- set )
+ current-height swapd [ kill-locations ] 2bi@
[ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
- append unique ;
+ append >hash-set ;
-SYMBOLS: height-state peek-sets replace-sets kill-sets ;
+SYMBOLS: height-state peek-sets replace-sets kill-sets locs>vregs ;
-SYMBOL: locs>vregs
+: inc-stack ( loc -- )
+ height-state get swap modify-height ;
: loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
: vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
-SYMBOLS: local-peek-set local-replace-set replace-mapping ;
+SYMBOLS: local-peek-set replaces ;
-: stack-changes ( replace-mapping -- insns )
+: replaces>copy-insns ( replaces -- insns )
[ [ loc>vreg ] dip ] assoc-map parallel-copy ;
-: emit-changes ( -- )
- building get pop
- replace-mapping get stack-changes %
- height-state get height-state>insns %
- , ;
-
-: inc-d ( n -- )
- height-state get swap <ds-loc> modify-height ;
+: changes>insns ( replaces height-state -- insns )
+ [ replaces>copy-insns ] [ height-state>insns ] bi* append ;
-: inc-r ( n -- )
- height-state get swap <rs-loc> modify-height ;
+: emit-changes ( replaces state -- )
+ building get pop -rot changes>insns % , ;
: peek-loc ( loc -- vreg )
- height-state get swap translate-local-loc
- dup replace-mapping get at
- [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
+ height-state get translate-local-loc dup replaces get at
+ [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
: replace-loc ( vreg loc -- )
- height-state get swap translate-local-loc
- replace-mapping get set-at ;
+ height-state get translate-local-loc replaces get set-at ;
-: compute-local-kill-set ( -- assoc )
- basic-block get [ rs-heights get at ] [ ds-heights get at ] bi
+: compute-local-kill-set ( basic-block -- set )
+ [ ds-heights get at ] [ rs-heights get at ] bi
height-state get local-kill-set ;
-: begin-local-analysis ( -- )
- H{ } clone local-peek-set set
- H{ } clone replace-mapping set
- height-state get
- [ reset-emits ] [
- first2 [ first ] bi@ basic-block get record-stack-heights
- ] bi ;
-
-: remove-redundant-replaces ( -- )
- replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
- [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
-
-: end-local-analysis ( -- )
- remove-redundant-replaces
- emit-changes
- 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 ;
-
-: peek-set ( bb -- assoc ) peek-sets get at ;
-: replace-set ( bb -- assoc ) replace-sets get at ;
-: kill-set ( bb -- assoc ) kill-sets get at ;
+: begin-local-analysis ( basic-block -- )
+ height-state get dup reset-emits
+ current-height rot record-stack-heights
+ HS{ } clone local-peek-set set
+ H{ } clone replaces set ;
+
+: remove-redundant-replaces ( replaces -- replaces' )
+ [ [ loc>vreg ] dip = not ] assoc-filter ;
+
+: end-local-analysis ( basic-block -- )
+ [
+ replaces get remove-redundant-replaces
+ dup height-state get emit-changes keys
+ swap replace-sets get set-at
+ ]
+ [ [ local-peek-set get ] dip peek-sets get set-at ]
+ [ [ compute-local-kill-set ] keep kill-sets get set-at ] tri ;