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