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
  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     ! If a live vreg is not in the pending set, then it must
  35     ! have been spilled.
  36     vreg leader :> leader
  37     leader pending-interval-assoc get at* [
  38         drop leader vreg rep-of lookup-spill-slot
  39     ] unless ;
  40
  41 ERROR: not-spilled-error vreg ;
  42
  43 : vreg>spill-slot ( vreg -- spill-slot )
  44     dup vreg>reg dup spill-slot? [ nip ] [ drop leader not-spilled-error ] if ;
  45
  46 : vregs>regs ( vregs -- assoc )
  47     [ f ] [ [ dup vreg>reg ] H{ } map>assoc ] if-empty ;
  48
  49 ! Minheap of live intervals which still need a register allocation
  50 SYMBOL: unhandled-intervals
  51
  52 : add-unhandled ( live-interval -- )
  53     dup start>> unhandled-intervals get heap-push ;
  54
  55 : init-unhandled ( live-intervals -- )
  56     [ add-unhandled ] each ;
  57
  58 ! Liveness info is used by resolve pass
  59
  60 ! Mapping from basic blocks to values which are live at the start
  61 ! on all incoming CFG edges
  62 SYMBOL: machine-live-ins
  63
  64 : machine-live-in ( bb -- assoc )
  65     machine-live-ins get at ;
  66
  67 : compute-live-in ( bb -- )
  68     [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
  69
  70 ! Mapping from basic blocks to predecessors to values which are
  71 ! live on a particular incoming edge
  72 SYMBOL: machine-edge-live-ins
  73
  74 : machine-edge-live-in ( predecessor bb -- assoc )
  75     machine-edge-live-ins get at at ;
  76
  77 : compute-edge-live-in ( bb -- )
  78     [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
  79     machine-edge-live-ins get set-at ;
  80
  81 ! Mapping from basic blocks to values which are live at the end
  82 SYMBOL: machine-live-outs
  83
  84 : machine-live-out ( bb -- assoc )
  85     machine-live-outs get at ;
  86
  87 : compute-live-out ( bb -- )
  88     [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
  89
  90 : init-assignment ( live-intervals -- )
  91     <min-heap> pending-interval-heap set
  92     H{ } clone pending-interval-assoc set
  93     <min-heap> unhandled-intervals set
  94     H{ } clone machine-live-ins set
  95     H{ } clone machine-edge-live-ins set
  96     H{ } clone machine-live-outs set
  97     init-unhandled ;
  98
  99 : insert-spill ( live-interval -- )
 100     [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill ;
 101
 102 : handle-spill ( live-interval -- )
 103     dup spill-to>> [ insert-spill ] [ drop ] if ;
 104
 105 : expire-interval ( live-interval -- )
 106     [ remove-pending ] [ handle-spill ] bi ;
 107
 108 : (expire-old-intervals) ( n heap -- )
 109     dup heap-empty? [ 2drop ] [
 110         2dup heap-peek nip <= [ 2drop ] [
 111             dup heap-pop drop expire-interval
 112             (expire-old-intervals)
 113         ] if
 114     ] if ;
 115
 116 : expire-old-intervals ( n -- )
 117     pending-interval-heap get (expire-old-intervals) ;
 118
 119 : insert-reload ( live-interval -- )
 120     [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload ;
 121
 122 : handle-reload ( live-interval -- )
 123     dup reload-from>> [ insert-reload ] [ drop ] if ;
 124
 125 : activate-interval ( live-interval -- )
 126     [ add-pending ] [ handle-reload ] bi ;
 127
 128 : (activate-new-intervals) ( n heap -- )
 129     dup heap-empty? [ 2drop ] [
 130         2dup heap-peek nip = [
 131             dup heap-pop drop activate-interval
 132             (activate-new-intervals)
 133         ] [ 2drop ] if
 134     ] if ;
 135
 136 : activate-new-intervals ( n -- )
 137     unhandled-intervals get (activate-new-intervals) ;
 138
 139 : prepare-insn ( n -- )
 140     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 141
 142 GENERIC: assign-registers-in-insn ( insn -- )
 143
 144 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 145
 146 M: vreg-insn assign-registers-in-insn
 147     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 148
 149 M: gc-map-insn assign-registers-in-insn
 150     [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
 151     [ gc-map>> [ [ vreg>spill-slot ] map ] change-gc-roots drop ]
 152     bi ;
 153
 154 M: insn assign-registers-in-insn drop ;
 155
 156 : begin-block ( bb -- )
 157     {
 158         [ basic-block set ]
 159         [ block-from activate-new-intervals ]
 160         [ compute-edge-live-in ]
 161         [ compute-live-in ]
 162     } cleave ;
 163
 164 :: assign-registers-in-block ( bb -- )
 165     bb kill-block?>> [
 166         bb [
 167             [
 168                 bb begin-block
 169                 [
 170                     {
 171                         [ insn#>> 1 - prepare-insn ]
 172                         [ insn#>> prepare-insn ]
 173                         [ assign-registers-in-insn ]
 174                         [ , ]
 175                     } cleave
 176                 ] each
 177                 bb compute-live-out
 178             ] V{ } make
 179         ] change-instructions drop
 180     ] unless ;
 181
 182 : assign-registers ( live-intervals cfg -- )
 183     [ init-assignment ] dip
 184     linearization-order [ assign-registers-in-block ] each ;