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 IN: compiler.cfg.stacks.local
  12
  13 ! Local stack analysis. We build local peek and replace sets for every basic
  14 ! block while constructing the CFG.
  15
  16 SYMBOLS: peek-sets replace-sets kill-sets ;
  17
  18 SYMBOL: locs>vregs
  19
  20 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
  21 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
  22
  23 TUPLE: current-height
  24 { d initial: 0 }
  25 { r initial: 0 }
  26 { emit-d initial: 0 }
  27 { emit-r initial: 0 } ;
  28
  29 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
  30
  31 GENERIC: translate-local-loc ( loc -- loc' )
  32 M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
  33 M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
  34
  35 : emit-stack-changes ( -- )
  36     replace-mapping get dup assoc-empty? [ drop ] [
  37         [ [ loc>vreg ] dip ] assoc-map parallel-copy
  38     ] if ;
  39
  40 : emit-height-changes ( -- )
  41     current-height get
  42     [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
  43     [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi ;
  44
  45 : emit-changes ( -- )
  46     ! Insert height and stack changes prior to the last instruction
  47     building get pop
  48     emit-stack-changes
  49     emit-height-changes
  50     , ;
  51
  52 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
  53 : inc-d ( n -- )
  54     current-height get
  55     [ [ + ] change-emit-d drop ]
  56     [ [ + ] change-d drop ]
  57     2bi ;
  58
  59 : inc-r ( n -- )
  60     current-height get
  61     [ [ + ] change-emit-r drop ]
  62     [ [ + ] change-r drop ]
  63     2bi ;
  64
  65 : peek-loc ( loc -- vreg )
  66     translate-local-loc
  67     dup local-replace-set get key? [ dup local-peek-set get conjoin ] unless
  68     dup replace-mapping get at [ ] [ loc>vreg ] ?if ;
  69
  70 : replace-loc ( vreg loc -- )
  71     translate-local-loc
  72     2dup loc>vreg =
  73     [ nip replace-mapping get delete-at ]
  74     [
  75         [ local-replace-set get conjoin ]
  76         [ replace-mapping get set-at ]
  77         bi
  78     ] if ;
  79
  80 : compute-local-kill-set ( -- assoc )
  81     basic-block get current-height get
  82     [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
  83     [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ]
  84     [ drop local-replace-set get at ] 2tri
  85     [ append unique dup ] dip update ;
  86
  87 : begin-local-analysis ( -- )
  88     H{ } clone local-peek-set set
  89     H{ } clone local-replace-set set
  90     H{ } clone replace-mapping set
  91     current-height get
  92     [ 0 >>emit-d 0 >>emit-r drop ]
  93     [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
  94
  95 : end-local-analysis ( -- )
  96     emit-changes
  97     basic-block get {
  98         [ [ local-peek-set get ] dip peek-sets get set-at ]
  99         [ [ local-replace-set get ] dip replace-sets get set-at ]
 100         [ [ compute-local-kill-set ] dip kill-sets get set-at ]
 101     } cleave ;
 102
 103 : clone-current-height ( -- )
 104     current-height [ clone ] change ;
 105
 106 : peek-set ( bb -- assoc ) peek-sets get at ;
 107 : replace-set ( bb -- assoc ) replace-sets get at ;
 108 : kill-set ( bb -- assoc ) kill-sets get at ;