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