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? over node? [ [ number>> ] same? ] [ 2drop f ] if ;
  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-vregs [ node swap definers set-at ] each
  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     ##allot
  59     ##load-memory ##load-memory-imm
  60     ##store-memory ##store-memory-imm
  61     ##write-barrier ##write-barrier-imm
  62     alien-call-insn
  63     slot-insn ;
  64
  65 : chain ( node var -- )
  66     dup get [
  67         pick +control+ precedes
  68     ] when*
  69     set ;
  70
  71 GENERIC: add-control-edge ( node insn -- )
  72
  73 M: stack-insn add-control-edge loc>> chain ;
  74
  75 M: memory-insn add-control-edge drop memory-insn chain ;
  76
  77 M: object add-control-edge 2drop ;
  78
  79 : add-control-edges ( nodes -- )
  80     [ [ dup insn>> add-control-edge ] each ] with-scope ;
  81
  82 : set-follows ( nodes -- )
  83     [
  84         dup precedes>> keys [
  85             follows>> push
  86         ] with each
  87     ] each ;
  88
  89 : set-roots ( nodes -- )
  90     [ ready? ] V{ } filter-as roots set ;
  91
  92 : build-dependence-graph ( instructions -- )
  93     [ <node> ] map {
  94         [ add-control-edges ]
  95         [ add-data-edges ]
  96         [ set-follows ]
  97         [ set-roots ]
  98         [ nodes set ]
  99     } cleave ;
 100
 101 ! Sethi-Ulmann numbering
 102 :: calculate-registers ( node -- registers )
 103     node children>> [ 0 ] [
 104         [ [ calculate-registers ] map natural-sort ]
 105         [ length iota ]
 106         bi v+ supremum
 107     ] if-empty
 108     node insn>> temp-vregs length +
 109     dup node registers<< ;
 110
 111 ! Constructing fan-in trees
 112
 113 : attach-parent ( node parent -- )
 114     [ >>parent drop ]
 115     [ [ ?push ] change-children drop ] 2bi ;
 116
 117 : keys-for ( assoc value -- keys )
 118     '[ nip _ = ] assoc-filter keys ;
 119
 120 : choose-parent ( node -- )
 121     ! If a node has control dependences, it has to be a root
 122     ! Otherwise, choose one of the data dependences for a parent
 123     dup precedes>> +control+ keys-for empty? [
 124         dup precedes>> +data+ keys-for [ drop ] [
 125             first attach-parent
 126         ] if-empty
 127     ] [ drop ] if ;
 128
 129 : make-trees ( -- trees )
 130     nodes get
 131     [ [ choose-parent ] each ]
 132     [ [ parent>> not ] filter ] bi ;
 133
 134 ERROR: node-missing-parent trees nodes ;
 135 ERROR: node-missing-children trees nodes ;
 136
 137 : flatten-tree ( node -- nodes )
 138     [ children>> [ flatten-tree ] map concat ] keep
 139     suffix ;
 140
 141 : verify-parents ( trees -- trees )
 142     nodes get over '[ [ parent>> ] [ _ member? ] bi or ] all?
 143     [ nodes get node-missing-parent ] unless ;
 144
 145 : verify-children ( trees -- trees )
 146     dup [ flatten-tree ] map concat
 147     nodes get
 148     { [ [ length ] same? ] [ set= ] } 2&&
 149     [ nodes get node-missing-children ] unless ;
 150
 151 : verify-trees ( trees -- trees )
 152     verify-parents verify-children ;
 153
 154 : build-fan-in-trees ( -- )
 155     make-trees verify-trees [
 156         -1/0. >>parent-index
 157         calculate-registers drop
 158     ] each ;