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