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 arrays 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 SYMBOLS: peek-sets replace-sets kill-sets ;
  11
  12 SYMBOL: locs>vregs
  13
  14 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
  15 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
  16
  17 TUPLE: current-height
  18 { d initial: 0 }
  19 { r initial: 0 }
  20 { emit-d initial: 0 }
  21 { emit-r initial: 0 } ;
  22
  23 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
  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 : stack-changes ( replace-mapping -- insns )
  30     [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
  31
  32 : height-changes ( current-height -- insns )
  33     [ emit-d>> ] [ emit-r>> ] bi 2array
  34     { ##inc-d ##inc-r } [ new swap >>n ] 2map [ n>> 0 = not ] filter ;
  35
  36 : emit-changes ( -- )
  37     building get pop
  38     replace-mapping get stack-changes %
  39     current-height get height-changes %
  40     , ;
  41
  42 ! inc-d/inc-r: these emit ##inc-d/##inc-r to change the stack height later
  43 : inc-d ( n -- )
  44     current-height get
  45     [ [ + ] change-emit-d drop ]
  46     [ [ + ] change-d drop ]
  47     2bi ;
  48
  49 : inc-r ( n -- )
  50     current-height get
  51     [ [ + ] change-emit-r drop ]
  52     [ [ + ] change-r drop ]
  53     2bi ;
  54
  55 : peek-loc ( loc -- vreg )
  56     translate-local-loc
  57     dup replace-mapping get at
  58     [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
  59
  60 : replace-loc ( vreg loc -- )
  61     translate-local-loc replace-mapping get set-at ;
  62
  63 : compute-local-kill-set ( -- assoc )
  64     basic-block get current-height get
  65     [ [ ds-heights get at dup ] [ d>> ] bi* [-] iota [ swap - <ds-loc> ] with map ]
  66     [ [ rs-heights get at dup ] [ r>> ] bi* [-] iota [ swap - <rs-loc> ] with map ] 2bi
  67     append unique ;
  68
  69 : begin-local-analysis ( -- )
  70     H{ } clone local-peek-set set
  71     H{ } clone replace-mapping set
  72     current-height get
  73     [ 0 >>emit-d 0 >>emit-r drop ]
  74     [ [ d>> ] [ r>> ] bi basic-block get record-stack-heights ] bi ;
  75
  76 : remove-redundant-replaces ( -- )
  77     replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
  78     [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
  79
  80 : end-local-analysis ( -- )
  81     remove-redundant-replaces
  82     emit-changes
  83     basic-block get {
  84         [ [ local-peek-set get ] dip peek-sets get set-at ]
  85         [ [ local-replace-set get ] dip replace-sets get set-at ]
  86         [ [ compute-local-kill-set ] dip kill-sets get set-at ]
  87     } cleave ;
  88
  89 : clone-current-height ( -- )
  90     current-height [ clone ] change ;
  91
  92 : peek-set ( bb -- assoc ) peek-sets get at ;
  93 : replace-set ( bb -- assoc ) replace-sets get at ;
  94 : kill-set ( bb -- assoc ) kill-sets get at ;