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
   6 kernel make math math.order namespaces sequences sets ;
   7 FROM: namespaces => set ;
   8 IN: compiler.cfg.stacks.local
   9
  10 : >loc< ( loc -- n ds? )
  11     [ n>> ] [ ds-loc? ] bi ;
  12
  13 : modify-height ( state loc -- )
  14     >loc< 0 1 ? rot nth [ + ] with map! drop ;
  15
  16 : adjust ( state loc -- )
  17     >loc< 0 1 ? rot nth dup first swapd + 0 rot set-nth ;
  18
  19 : reset-emits ( state -- )
  20     [ 0 1 rot set-nth ] each ;
  21
  22 : height-state>insns ( state -- insns )
  23     [ second ] map { ds-loc rs-loc } [ new swap >>n ] 2map
  24     [ n>> 0 = not ] filter [ ##inc new swap >>loc ] map ;
  25
  26 : translate-local-loc ( state loc -- loc' )
  27     >loc< [ 0 1 ? rot nth first - ] keep ds-loc rs-loc ? new swap >>n ;
  28
  29 : clone-height-state ( state -- state' )
  30     [ clone ] map ;
  31
  32 : initial-height-state ( -- state )
  33     { { 0 0 } { 0 0 } } clone-height-state ;
  34
  35 : kill-locations ( saved-height height -- seq )
  36     dupd [-] iota [ swap - ] with map ;
  37
  38 : local-kill-set ( ds-height rs-height state -- assoc )
  39     first2 [ first ] bi@ swapd [ kill-locations ] 2bi@
  40     [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
  41     append unique ;
  42
  43 SYMBOLS: height-state peek-sets replace-sets kill-sets ;
  44
  45 SYMBOL: locs>vregs
  46
  47 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
  48 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
  49
  50 SYMBOLS: local-peek-set local-replace-set replace-mapping ;
  51
  52 : stack-changes ( replace-mapping -- insns )
  53     [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
  54
  55 : emit-changes ( -- )
  56     building get pop
  57     replace-mapping get stack-changes %
  58     height-state get height-state>insns %
  59     , ;
  60
  61 : inc-d ( n -- )
  62     height-state get swap <ds-loc> modify-height ;
  63
  64 : inc-r ( n -- )
  65     height-state get swap <rs-loc> modify-height ;
  66
  67 : peek-loc ( loc -- vreg )
  68     height-state get swap translate-local-loc
  69     dup replace-mapping get at
  70     [ ] [ dup local-peek-set get conjoin loc>vreg ] ?if ;
  71
  72 : replace-loc ( vreg loc -- )
  73     height-state get swap translate-local-loc
  74     replace-mapping get set-at ;
  75
  76 : compute-local-kill-set ( -- assoc )
  77     basic-block get [ rs-heights get at ] [ ds-heights get at ] bi
  78     height-state get local-kill-set ;
  79
  80 : begin-local-analysis ( -- )
  81     H{ } clone local-peek-set set
  82     H{ } clone replace-mapping set
  83     height-state get
  84     [ reset-emits ] [
  85         first2 [ first ] bi@ basic-block get record-stack-heights
  86     ] bi ;
  87
  88 : remove-redundant-replaces ( -- )
  89     replace-mapping get [ [ loc>vreg ] dip = not ] assoc-filter
  90     [ replace-mapping set ] [ keys unique local-replace-set set ] bi ;
  91
  92 : end-local-analysis ( -- )
  93     remove-redundant-replaces
  94     emit-changes
  95     basic-block get {
  96         [ [ local-peek-set get ] dip peek-sets get set-at ]
  97         [ [ local-replace-set get ] dip replace-sets get set-at ]
  98         [ [ compute-local-kill-set ] dip kill-sets get set-at ]
  99     } cleave ;
 100
 101 : peek-set ( bb -- assoc ) peek-sets get at ;
 102 : replace-set ( bb -- assoc ) replace-sets get at ;
 103 : kill-set ( bb -- assoc ) kill-sets get at ;