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