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