basis/compiler/cfg/stack-analysis/merge/merge.factor

   1 ! Copyright (C) 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: kernel assocs sequences accessors fry combinators grouping sets
   4 arrays vectors locals namespaces make compiler.cfg compiler.cfg.hats
   5 compiler.cfg.instructions compiler.cfg.stack-analysis.state
   6 compiler.cfg.registers compiler.cfg.utilities cpu.architecture ;
   7 IN: compiler.cfg.stack-analysis.merge
   8
   9 : initial-state ( bb states -- state ) 2drop <state> ;
  10
  11 : single-predecessor ( bb states -- state ) nip first clone ;
  12
  13 : save-ds-height ( n -- )
  14     dup 0 = [ drop ] [ ##inc-d ] if ;
  15
  16 : merge-ds-heights ( state predecessors states -- state )
  17     [ ds-height>> ] map dup all-equal?
  18     [ nip first >>ds-height ]
  19     [ [ '[ _ save-ds-height ] add-instructions ] 2each ] if ;
  20
  21 : save-rs-height ( n -- )
  22     dup 0 = [ drop ] [ ##inc-r ] if ;
  23
  24 : merge-rs-heights ( state predecessors states -- state )
  25     [ rs-height>> ] map dup all-equal?
  26     [ nip first >>rs-height ]
  27     [ [ '[ _ save-rs-height ] add-instructions ] 2each ] if ;
  28
  29 : assoc-map-keys ( assoc quot -- assoc' )
  30     '[ _ dip ] assoc-map ; inline
  31
  32 : translate-locs ( assoc state -- assoc' )
  33     '[ _ translate-loc ] assoc-map-keys ;
  34
  35 : untranslate-locs ( assoc state -- assoc' )
  36     '[ _ untranslate-loc ] assoc-map-keys ;
  37
  38 : collect-locs ( loc-maps states -- assoc )
  39     ! assoc maps locs to sequences
  40     [ untranslate-locs ] 2map
  41     [ [ keys ] map concat prune ] keep
  42     '[ dup _ [ at ] with map ] H{ } map>assoc ;
  43
  44 : insert-peek ( predecessor loc state -- vreg )
  45     '[ _ _ translate-loc ^^peek ] add-instructions ;
  46
  47 SYMBOL: added-phis
  48
  49 : add-phi-later ( inputs -- vreg )
  50     [ int-regs next-vreg dup ] dip 2array added-phis get push ;
  51
  52 : merge-loc ( predecessors vregs loc state -- vreg )
  53     ! Insert a ##phi in the current block where the input
  54     ! is the vreg storing loc from each predecessor block
  55     '[ [ ] [ _ _ insert-peek ] ?if ] 2map
  56     dup all-equal? [ first ] [ add-phi-later ] if ;
  57
  58 :: merge-locs ( state predecessors states -- state )
  59     states [ locs>vregs>> ] map states collect-locs
  60     [| key value |
  61         key
  62         predecessors value key state merge-loc
  63     ] assoc-map
  64     state translate-locs
  65     state (>>locs>vregs)
  66     state ;
  67
  68 : merge-actual-loc ( vregs -- vreg/f )
  69     dup all-equal? [ first ] [ drop f ] if ;
  70
  71 :: merge-actual-locs ( state states -- state )
  72     states [ actual-locs>vregs>> ] map states collect-locs
  73     [ merge-actual-loc ] assoc-map [ nip ] assoc-filter
  74     state translate-locs
  75     state (>>actual-locs>vregs)
  76     state ;
  77
  78 : merge-changed-locs ( state states -- state )
  79     [ [ changed-locs>> ] keep untranslate-locs ] map assoc-combine
  80     over translate-locs
  81     >>changed-locs ;
  82
  83 :: insert-phis ( bb -- )
  84     bb predecessors>> :> predecessors
  85     [
  86         added-phis get [| dst inputs |
  87             dst predecessors inputs zip ##phi
  88         ] assoc-each
  89     ] V{ } make bb instructions>> over push-all
  90     bb (>>instructions) ;
  91
  92 :: multiple-predecessors ( bb states -- state )
  93     states [ not ] any? [
  94         <state>
  95         bb add-to-work-list
  96     ] [
  97         [
  98             H{ } clone added-instructions set
  99             V{ } clone added-phis set
 100             bb predecessors>> :> predecessors
 101             state new
 102             predecessors states merge-ds-heights
 103             predecessors states merge-rs-heights
 104             predecessors states merge-locs
 105             states merge-actual-locs
 106             states merge-changed-locs
 107             bb insert-basic-blocks
 108             bb insert-phis
 109         ] with-scope
 110     ] if ;
 111
 112 : merge-states ( bb states -- state )
 113     dup length {
 114         { 0 [ initial-state ] }
 115         { 1 [ single-predecessor ] }
 116         [ drop multiple-predecessors ]
 117     } case ;