basis/compiler/cfg/linear-scan/assignment/assignment.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators compiler.cfg
   4 compiler.cfg.linearization compiler.cfg.liveness compiler.cfg.registers
   5 compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
   6 compiler.cfg.linear-scan.live-intervals compiler.cfg.renaming.functor
   7 compiler.cfg.ssa.destruction.leaders cpu.architecture
   8 fry heaps kernel locals make math namespaces sequences sets ;
   9 FROM: namespaces => set ;
  10 IN: compiler.cfg.linear-scan.assignment
  11
  12 ! This contains both active and inactive intervals; any interval
  13 ! such that start <= insn# <= end is in this set.
  14 SYMBOL: pending-interval-heap
  15 SYMBOL: pending-interval-assoc
  16
  17 : add-pending ( live-interval -- )
  18     [ dup end>> pending-interval-heap get heap-push ]
  19     [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
  20     bi ;
  21
  22 : remove-pending ( live-interval -- )
  23     vreg>> pending-interval-assoc get delete-at ;
  24
  25 :: vreg>reg ( vreg -- reg )
  26     vreg leader :> leader
  27     leader pending-interval-assoc get at* [
  28         drop leader vreg rep-of lookup-spill-slot
  29     ] unless ;
  30
  31 ERROR: not-spilled-error vreg ;
  32
  33 : vreg>spill-slot ( vreg -- spill-slot )
  34     dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
  35
  36 : vregs>regs ( vregs -- assoc )
  37     [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
  38
  39 SYMBOL: unhandled-intervals
  40
  41 : init-unhandled ( live-intervals -- unhandled-intervals  )
  42     [ dup start>> swap 2array ] map >min-heap  ;
  43
  44 ! Liveness info is used by resolve pass
  45 SYMBOL: machine-live-ins
  46
  47 : machine-live-in ( bb -- assoc )
  48     machine-live-ins get at ;
  49
  50 : compute-live-in ( bb -- )
  51     [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
  52
  53 ! Mapping from basic blocks to predecessors to values which are
  54 ! live on a particular incoming edge
  55 SYMBOL: machine-edge-live-ins
  56
  57 : machine-edge-live-in ( predecessor bb -- assoc )
  58     machine-edge-live-ins get at at ;
  59
  60 : compute-edge-live-in ( bb -- )
  61     [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
  62     machine-edge-live-ins get set-at ;
  63
  64 SYMBOL: machine-live-outs
  65
  66 : machine-live-out ( bb -- assoc )
  67     machine-live-outs get at ;
  68
  69 : compute-live-out ( bb -- )
  70     [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
  71
  72 : init-assignment ( live-intervals -- )
  73     init-unhandled unhandled-intervals set
  74     <min-heap> pending-interval-heap set
  75     H{ } clone pending-interval-assoc set
  76     H{ } clone machine-live-ins set
  77     H{ } clone machine-edge-live-ins set
  78     H{ } clone machine-live-outs set ;
  79
  80 : insert-spill ( live-interval -- )
  81     [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
  82
  83 : handle-spill ( live-interval -- )
  84     dup spill-to>> [ insert-spill ] [ drop ] if ;
  85
  86 : expire-interval ( live-interval -- )
  87     [ remove-pending ] [ handle-spill ] bi ;
  88
  89 : (expire-old-intervals) ( n heap -- )
  90     dup heap-empty? [ 2drop ] [
  91         2dup heap-peek nip <= [ 2drop ] [
  92             dup heap-pop drop expire-interval
  93             (expire-old-intervals)
  94         ] if
  95     ] if ;
  96
  97 : expire-old-intervals ( n -- )
  98     pending-interval-heap get (expire-old-intervals) ;
  99
 100 : insert-reload ( live-interval -- )
 101     [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
 102
 103 : handle-reload ( live-interval -- )
 104     dup reload-from>> [ insert-reload ] [ drop ] if ;
 105
 106 : activate-interval ( live-interval -- )
 107     [ add-pending ] [ handle-reload ] bi ;
 108
 109 : (activate-new-intervals) ( n heap -- )
 110     dup heap-empty? [ 2drop ] [
 111         2dup heap-peek nip = [
 112             dup heap-pop drop activate-interval
 113             (activate-new-intervals)
 114         ] [ 2drop ] if
 115     ] if ;
 116
 117 : activate-new-intervals ( n -- )
 118     unhandled-intervals get (activate-new-intervals) ;
 119
 120 : prepare-insn ( n -- )
 121     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 122
 123 GENERIC: assign-registers-in-insn ( insn -- )
 124
 125 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 126
 127 M: vreg-insn assign-registers-in-insn
 128     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 129
 130 : assign-gc-roots ( gc-map -- )
 131     [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
 132
 133 : assign-derived-roots ( gc-map -- )
 134     [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
 135
 136 M: gc-map-insn assign-registers-in-insn
 137     [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
 138     [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
 139     bi ;
 140
 141 M: insn assign-registers-in-insn drop ;
 142
 143 : begin-block ( bb -- )
 144     {
 145         [ basic-block set ]
 146         [ block-from activate-new-intervals ]
 147         [ compute-edge-live-in ]
 148         [ compute-live-in ]
 149     } cleave ;
 150
 151 :: assign-registers-in-block ( bb -- )
 152     bb [
 153         [
 154             bb begin-block
 155             [
 156                 {
 157                     [ insn#>> 1 - prepare-insn ]
 158                     [ insn#>> prepare-insn ]
 159                     [ assign-registers-in-insn ]
 160                     [ , ]
 161                 } cleave
 162             ] each
 163             bb compute-live-out
 164         ] V{ } make
 165     ] change-instructions drop ;
 166
 167 : assign-registers ( live-intervals cfg -- )
 168     [ init-assignment ] dip
 169     linearization-order [ kill-block?>> not ] filter
 170     [ assign-registers-in-block ] each ;