! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs kernel math namespaces sets make sequences
-compiler.cfg compiler.cfg.hats
-compiler.cfg.instructions compiler.cfg.registers
-compiler.cfg.stacks.height ;
+USING: accessors arrays assocs combinators compiler.cfg
+compiler.cfg.instructions compiler.cfg.parallel-copy
+compiler.cfg.registers compiler.cfg.stacks.height
+fry hash-sets kernel make math math.order namespaces sequences sets ;
+FROM: namespaces => set ;
IN: compiler.cfg.stacks.local
-! Local stack analysis. We build local peek and replace sets for every basic
-! block while constructing the CFG.
+: current-height ( state -- ds rs )
+ first2 [ first ] bi@ ;
-SYMBOLS: peek-sets replace-sets ;
+: >loc< ( loc -- n ds? )
+ [ n>> ] [ ds-loc? ] bi ;
-SYMBOL: locs>vregs
+: modify-height ( state loc -- )
+ >loc< 0 1 ? rot nth [ + ] with map! drop ;
-: loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
+: adjust ( state loc -- )
+ >loc< 0 1 ? rot nth dup first swapd + 0 rot set-nth ;
-TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
+: reset-emits ( state -- )
+ [ 0 1 rot set-nth ] each ;
-SYMBOLS: copies local-peek-set local-replace-set ;
+: height-state>insns ( state -- insns )
+ [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
+ [ n>> 0 = ] reject [ ##inc new swap >>loc ] map ;
-: record-copy ( dst src -- ) swap copies get set-at ;
-: resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
+: translate-local-loc ( loc state -- loc' )
+ [ clone ] dip over >loc< 0 1 ? rot nth first - >>n ;
-GENERIC: translate-local-loc ( loc -- loc' )
-M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
-M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
+: clone-height-state ( state -- state' )
+ [ clone ] map ;
-: emit-height-changes ( -- )
- ! Insert height changes prior to the last instruction
- building get pop
- current-height get
- [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
- [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi
- , ;
+: initial-height-state ( -- state )
+ { { 0 0 } { 0 0 } } clone-height-state ;
-! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
-: inc-d ( n -- )
- current-height get
- [ [ + ] change-emit-d drop ]
- [ [ + ] change-d drop ]
- 2bi ;
+: kill-locations ( saved-height height -- seq )
+ dupd [-] iota [ swap - ] with map ;
-: inc-r ( n -- )
- current-height get
- [ [ + ] change-emit-r drop ]
- [ [ + ] change-r drop ]
- 2bi ;
+: local-kill-set ( ds-height rs-height state -- set )
+ current-height swapd [ kill-locations ] 2bi@
+ [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
+ append >hash-set ;
+
+SYMBOLS: height-state peek-sets replace-sets kill-sets 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 replaces ;
+
+: replaces>copy-insns ( replaces -- insns )
+ [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
+
+: changes>insns ( replaces height-state -- insns )
+ [ replaces>copy-insns ] [ height-state>insns ] bi* append ;
+
+: emit-changes ( replaces state -- )
+ building get pop -rot changes>insns % , ;
: peek-loc ( loc -- vreg )
- translate-local-loc
- [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ]
- [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ]
- bi ;
+ height-state get translate-local-loc dup replaces get at
+ [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
: replace-loc ( vreg loc -- )
- translate-local-loc
- 2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [
- [ local-replace-set get conjoin ]
- [ loc>vreg swap ##copy ]
- bi
- ] if ;
-
-: begin-local-analysis ( -- )
- H{ } clone copies set
- H{ } clone local-peek-set set
- H{ } clone local-replace-set set
- current-height get 0 >>emit-d 0 >>emit-r drop
- current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
-
-: end-local-analysis ( -- )
- emit-height-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 ;
-
-: clone-current-height ( -- )
- current-height [ clone ] change ;
-
-: peek-set ( bb -- assoc ) peek-sets get at ;
-: replace-set ( bb -- assoc ) replace-sets get at ;
+ height-state get translate-local-loc replaces get set-at ;
+
+: 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 ( 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 ;
projects / factor.git / blobdiff