basis/compiler/cfg/stacks/local/local.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators compiler.cfg
   4 compiler.cfg.instructions compiler.cfg.parallel-copy
   5 compiler.cfg.registers compiler.cfg.stacks.height kernel make
   6 math math.order namespaces sequences sets ;
   7 FROM: namespaces => set ;
   8 IN: compiler.cfg.stacks.local
   9
  10 ! Local stack analysis. We build three sets for every basic block
  11 ! in the CFG:
  12 ! - peek-set: all stack locations that the block reads before writing
  13 ! - replace-set: all stack locations that the block writes
  14 ! - kill-set: all stack locations which become unavailable after the
  15 !   block ends because of the stack height being decremented
  16 ! This is done while constructing the CFG.
  17
  18 SYMBOLS: peek-sets replace-sets kill-sets ;
  19
  20 SYMBOL: locs>vregs
  21
  22 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
  23 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
  24
  25 TUPLE: current-height
  26 { d initial: 0 }
  27 { r initial: 0 }
  28 { emit-d initial: 0 }
  29 { emit-r initial: 0 } ;
  30
  31 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
  32
  33 GENERIC: translate-local-loc ( loc -- loc' )
  34 M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
  35 M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
  36
  37 : emit-stack-changes ( -- )
  38     replace-mapping get dup assoc-empty? [ drop ] [
  39         [ [ loc>vreg ] dip ] assoc-map parallel-copy
  40     ] if ;
  41
  42 : emit-height-changes ( -- )
  43     current-height get
  44     [ emit-d>> dup 0 = [ drop ] [ ##inc-d, ] if ]
  45     [ emit-r>> dup 0 = [ drop ] [ ##inc-r, ] if ] bi ;
  46
  47 : emit-changes ( -- )
  48     ! Insert height and stack changes prior to the last instruction
  49     building get pop
  50     emit-stack-changes
  51     emit-height-changes
  52     , ;
  53
  54 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
  55 : inc-d ( n -- )
  56     current-height get
  57     [ [ + ] change-emit-d drop ]
  58     [ [ + ] change-d drop ]
  59     2bi ;
  60
  61 : inc-r ( n -- )
  62     current-height get
  63     [ [ + ] change-emit-r drop ]
  64     [ [ + ] change-r drop ]
  65     2bi ;
  66
  67 : peek-loc ( loc -- vreg )
  68     translate-local-loc
  69     dup replace-mapping get at
  70     [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
  71
  72 : replace-loc ( vreg loc -- )
  73     translate-local-loc replace-mapping get set-at ;
  74
  75 : compute-local-kill-set ( -- assoc )
  76     basic-block get current-height get
  77     [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
  78     [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
  79     append unique ;
  80
  81 : begin-local-analysis ( -- )
  82     H{ } clone local-peek-set set
  83     H{ } clone replace-mapping set
  84     current-height get
  85     [ 0 >>emit-d 0 >>emit-r drop ]
  86     [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
  87
  88 : remove-redundant-replaces ( -- )
  89     replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
  90     [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
  91
  92 : end-local-analysis ( -- )
  93     remove-redundant-replaces
  94     emit-changes
  95     basic-block get {
  96         [ [ local-peek-set get ] dip peek-sets get set-at ]
  97         [ [ local-replace-set get ] dip replace-sets get set-at ]
  98         [ [ compute-local-kill-set ] dip kill-sets get set-at ]
  99     } cleave ;
 100
 101 : clone-current-height ( -- )
 102     current-height [ clone ] change ;
 103
 104 : peek-set ( bb -- assoc ) peek-sets get at ;
 105 : replace-set ( bb -- assoc ) replace-sets get at ;
 106 : kill-set ( bb -- assoc ) kill-sets get at ;