basis/compiler/cfg/dependence/dependence.factor

   1 ! Copyright (C) 2009, 2010 Daniel Ehrenberg.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators compiler.cfg.def-use
   4 compiler.cfg.instructions compiler.cfg.registers fry kernel
   5 locals namespaces sequences sets sorting math.vectors
   6 make math combinators.short-circuit vectors ;
   7 FROM: namespaces => set ;
   8 IN: compiler.cfg.dependence
   9
  10 ! Dependence graph construction
  11
  12 SYMBOL: roots
  13 SYMBOL: node-number
  14 SYMBOL: nodes
  15
  16 SYMBOL: +data+
  17 SYMBOL: +control+
  18
  19 ! Nodes in the dependency graph
  20 ! These need to be numbered so that the same instruction
  21 ! will get distinct nodes if it occurs multiple times
  22 TUPLE: node
  23     number insn precedes follows
  24     children parent
  25     registers parent-index ;
  26
  27 M: node equal?  [ number>> ] bi@ = ;
  28
  29 M: node hashcode* nip number>> ;
  30
  31 : <node> ( insn -- node )
  32     node new
  33         node-number counter >>number
  34         swap >>insn
  35         H{ } clone >>precedes
  36         V{ } clone >>follows ;
  37
  38 : ready? ( node -- ? ) precedes>> assoc-empty? ;
  39
  40 :: precedes ( first second how -- )
  41     how second first precedes>> set-at ;
  42
  43 :: add-data-edges ( nodes -- )
  44     ! This builds up def-use information on the fly, since
  45     ! we only care about local def-use
  46     H{ } clone :> definers
  47     nodes [| node |
  48         node insn>> defs-vreg [ node swap definers set-at ] when*
  49         node insn>> uses-vregs [ definers at [ node +data+ precedes ] when* ] each
  50     ] each ;
  51
  52 UNION: stack-insn ##peek ##replace ##replace-imm ;
  53
  54 UNION: slot-insn
  55     ##read ##write ;
  56
  57 UNION: memory-insn
  58     ##load-memory ##load-memory-imm
  59     ##store-memory ##store-memory-imm ;
  60
  61 UNION: alien-call-insn
  62     ##save-context
  63     ##alien-invoke ##alien-indirect ##alien-callback
  64     ##unary-float-function ##binary-float-function ;
  65
  66 : chain ( node var -- )
  67     dup get [
  68         pick +control+ precedes
  69     ] when*
  70     set ;
  71
  72 GENERIC: add-control-edge ( node insn -- )
  73
  74 M: stack-insn add-control-edge
  75     loc>> chain ;
  76
  77 M: memory-insn add-control-edge
  78     drop memory-insn chain ;
  79
  80 M: slot-insn add-control-edge
  81     drop slot-insn chain ;
  82
  83 M: alien-call-insn add-control-edge
  84     drop alien-call-insn chain ;
  85
  86 M: object add-control-edge 2drop ;
  87
  88 : add-control-edges ( nodes -- )
  89     [
  90         [ dup insn>> add-control-edge ] each
  91     ] with-scope ;
  92
  93 : set-follows ( nodes -- )
  94     [
  95         dup precedes>> keys [
  96             follows>> push
  97         ] with each
  98     ] each ;
  99
 100 : set-roots ( nodes -- )
 101     [ ready? ] V{ } filter-as roots set ;
 102
 103 : build-dependence-graph ( instructions -- )
 104     [ <node> ] map {
 105         [ add-control-edges ]
 106         [ add-data-edges ]
 107         [ set-follows ]
 108         [ set-roots ]
 109         [ nodes set ]
 110     } cleave ;
 111
 112 ! Sethi-Ulmann numbering
 113 :: calculate-registers ( node -- registers )
 114     node children>> [ 0 ] [
 115         [ [ calculate-registers ] map natural-sort ]
 116         [ length iota ]
 117         bi v+ supremum
 118     ] if-empty
 119     node insn>> temp-vregs length +
 120     dup node registers<< ;
 121
 122 ! Constructing fan-in trees
 123
 124 : attach-parent ( node parent -- )
 125     [ >>parent drop ]
 126     [ [ ?push ] change-children drop ] 2bi ;
 127
 128 : keys-for ( assoc value -- keys )
 129     '[ nip _ = ] assoc-filter keys ;
 130
 131 : choose-parent ( node -- )
 132     ! If a node has control dependences, it has to be a root
 133     ! Otherwise, choose one of the data dependences for a parent
 134     dup precedes>> +control+ keys-for empty? [
 135         dup precedes>> +data+ keys-for [ drop ] [
 136             first attach-parent
 137         ] if-empty
 138     ] [ drop ] if ;
 139
 140 : make-trees ( -- trees )
 141     nodes get
 142     [ [ choose-parent ] each ]
 143     [ [ parent>> not ] filter ] bi ;
 144
 145 ERROR: node-missing-parent trees nodes ;
 146 ERROR: node-missing-children trees nodes ;
 147
 148 : flatten-tree ( node -- nodes )
 149     [ children>> [ flatten-tree ] map concat ] keep
 150     suffix ;
 151
 152 : verify-parents ( trees -- trees )
 153     nodes get over '[ [ parent>> ] [ _ member? ] bi or ] all?
 154     [ nodes get node-missing-parent ] unless ;
 155
 156 : verify-children ( trees -- trees )
 157     dup [ flatten-tree ] map concat
 158     nodes get
 159     { [ [ length ] bi@ = ] [ set= ] } 2&&
 160     [ nodes get node-missing-children ] unless ;
 161
 162 : verify-trees ( trees -- trees )
 163     verify-parents verify-children ;
 164
 165 : build-fan-in-trees ( -- )
 166     make-trees verify-trees [
 167         -1/0. >>parent-index
 168         calculate-registers drop
 169     ] each ;