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 namespaces sets make sequences
   4 compiler.cfg compiler.cfg.hats
   5 compiler.cfg.instructions compiler.cfg.registers
   6 compiler.cfg.stacks.height ;
   7 IN: compiler.cfg.stacks.local
   8
   9 ! Local stack analysis. We build local peek and replace sets for every basic
  10 ! block while constructing the CFG.
  11
  12 SYMBOLS: peek-sets replace-sets ;
  13
  14 SYMBOL: locs>vregs
  15
  16 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop i ] cache ;
  17
  18 TUPLE: current-height { d initial: 0 } { r initial: 0 } { emit-d initial: 0 } { emit-r initial: 0 } ;
  19
  20 SYMBOLS: copies local-peek-set local-replace-set ;
  21
  22 : record-copy ( dst src -- ) swap copies get set-at ;
  23 : resolve-copy ( vreg -- vreg' ) copies get ?at drop ;
  24
  25 GENERIC: translate-local-loc ( loc -- loc' )
  26 M: ds-loc translate-local-loc n>> current-height get d>> - <ds-loc> ;
  27 M: rs-loc translate-local-loc n>> current-height get r>> - <rs-loc> ;
  28
  29 : emit-height-changes ( -- )
  30     ! Insert height changes prior to the last instruction
  31     building get pop
  32     current-height get
  33     [ emit-d>> dup 0 = [ drop ] [ ##inc-d ] if ]
  34     [ emit-r>> dup 0 = [ drop ] [ ##inc-r ] if ] bi
  35     , ;
  36
  37 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
  38 : inc-d ( n -- )
  39     current-height get
  40     [ [ + ] change-emit-d drop ]
  41     [ [ + ] change-d drop ]
  42     2bi ;
  43
  44 : inc-r ( n -- )
  45     current-height get
  46     [ [ + ] change-emit-r drop ]
  47     [ [ + ] change-r drop ]
  48     2bi ;
  49
  50 : peek-loc ( loc -- vreg )
  51     translate-local-loc
  52     [ dup local-replace-set get key? [ drop ] [ local-peek-set get conjoin ] if ]
  53     [ loc>vreg [ i ] dip [ record-copy ] [ ##copy ] [ drop ] 2tri ]
  54     bi ;
  55
  56 : replace-loc ( vreg loc -- )
  57     translate-local-loc
  58     2dup [ resolve-copy ] dip loc>vreg = [ 2drop ] [
  59         [ local-replace-set get conjoin ]
  60         [ loc>vreg swap ##copy ]
  61         bi
  62     ] if ;
  63
  64 : begin-local-analysis ( -- )
  65     H{ } clone copies set
  66     H{ } clone local-peek-set set
  67     H{ } clone local-replace-set set
  68     current-height get 0 >>emit-d 0 >>emit-r drop
  69     current-height get [ d>> ] [ r>> ] bi basic-block get record-stack-heights ;
  70
  71 : end-local-analysis ( -- )
  72     emit-height-changes
  73     local-peek-set get basic-block get peek-sets get set-at
  74     local-replace-set get basic-block get replace-sets get set-at ;
  75
  76 : clone-current-height ( -- )
  77     current-height [ clone ] change ;
  78
  79 : peek-set ( bb -- assoc ) peek-sets get at ;
  80 : replace-set ( bb -- assoc ) replace-sets get at ;