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