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.instructions
   4 compiler.cfg.parallel-copy compiler.cfg.registers fry hash-sets kernel
   5 make math math.order namespaces sequences sets ;
   6 IN: compiler.cfg.stacks.local
   7
   8 TUPLE: height-state ds-begin rs-begin ds-inc rs-inc ;
   9
  10 : >loc< ( loc -- n ds? )
  11     [ n>> ] [ ds-loc? ] bi ;
  12
  13 : ds-height ( height-state -- n )
  14     [ ds-begin>> ] [ ds-inc>> ] bi + ;
  15
  16 : rs-height ( height-state -- n )
  17     [ rs-begin>> ] [ rs-inc>> ] bi + ;
  18
  19 : global-loc>local ( loc height-state -- loc' )
  20     [ clone dup >loc< ] dip swap [ ds-height ] [ rs-height ] if - >>n ;
  21
  22 : local-loc>global ( loc height-state -- loc' )
  23     [ clone dup >loc< ] dip swap [ ds-begin>> ] [ rs-begin>> ] if + >>n ;
  24
  25 : inc-stack ( loc -- )
  26     >loc< height-state get swap
  27     [ [ + ] change-ds-inc ] [ [ + ] change-rs-inc ] if drop ;
  28
  29 : height-state>insns ( height-state -- insns )
  30     [ ds-inc>> ds-loc ] [ rs-inc>> rs-loc ] bi [ new swap >>n ] 2bi@ 2array
  31     [ n>> 0 = ] reject [ ##inc new swap >>loc ] map ;
  32
  33 : reset-incs ( height-state -- )
  34     dup ds-inc>> '[ _ + ] change-ds-begin
  35     dup rs-inc>> '[ _ + ] change-rs-begin
  36     0 >>ds-inc 0 >>rs-inc drop ;
  37
  38 SYMBOLS: locs>vregs local-peek-set replaces ;
  39
  40 : loc>vreg ( loc -- vreg ) locs>vregs get [ drop next-vreg ] cache ;
  41 : vreg>loc ( vreg -- loc/f ) locs>vregs get value-at ;
  42
  43 : replaces>copy-insns ( replaces -- insns )
  44     [ [ loc>vreg ] dip ] assoc-map parallel-copy ;
  45
  46 : changes>insns ( replaces height-state -- insns )
  47     [ replaces>copy-insns ] [ height-state>insns ] bi* append ;
  48
  49 : emit-insns ( replaces state -- )
  50     building get pop -rot changes>insns % , ;
  51
  52 : peek-loc ( loc -- vreg )
  53     height-state get global-loc>local
  54     dup replaces get at
  55     [ ] [ dup local-peek-set get adjoin loc>vreg ] ?if ;
  56
  57 : replace-loc ( vreg loc -- )
  58     height-state get global-loc>local replaces get set-at ;
  59
  60 : kill-locations ( begin inc -- seq )
  61     0 min neg iota [ swap - ] with map ;
  62
  63 : local-kill-set ( ds-begin ds-inc rs-begin rs-inc -- set )
  64     [ kill-locations ] 2bi@
  65     [ [ <ds-loc> ] map ] [ [ <rs-loc> ] map ] bi*
  66     append >hash-set ;
  67
  68 : compute-local-kill-set ( height-state -- set )
  69     { [ ds-begin>> ] [ ds-inc>> ] [ rs-begin>> ] [ rs-inc>> ] } cleave
  70     local-kill-set ;
  71
  72 : begin-local-analysis ( basic-block -- )
  73     height-state [ clone ] change
  74     height-state get [ reset-incs ] keep >>height drop
  75     HS{ } clone local-peek-set namespaces:set
  76     H{ } clone replaces namespaces:set ;
  77
  78 : remove-redundant-replaces ( replaces -- replaces' )
  79     [ [ loc>vreg ] dip = ] assoc-reject ;
  80
  81 : end-local-analysis ( basic-block -- )
  82     replaces get remove-redundant-replaces
  83     over kill-block?>> [
  84         [ height-state get emit-insns ] keep
  85     ] unless
  86     keys >hash-set >>replaces
  87     local-peek-set get >>peeks
  88     height-state get compute-local-kill-set >>kills drop ;