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

   1 ! Copyright (C) 2008, 2009 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 sets locals
   5 cpu.architecture
   6 compiler.cfg
   7 compiler.cfg.rpo
   8 compiler.cfg.def-use
   9 compiler.cfg.liveness
  10 compiler.cfg.registers
  11 compiler.cfg.instructions
  12 compiler.cfg.linear-scan.mapping
  13 compiler.cfg.linear-scan.allocation
  14 compiler.cfg.linear-scan.allocation.state
  15 compiler.cfg.linear-scan.live-intervals ;
  16 IN: compiler.cfg.linear-scan.assignment
  17
  18 ! This contains both active and inactive intervals; any interval
  19 ! such that start <= insn# <= end is in this set.
  20 SYMBOL: pending-intervals
  21
  22 : add-active ( live-interval -- )
  23     dup end>> pending-intervals get heap-push ;
  24
  25 ! Minheap of live intervals which still need a register allocation
  26 SYMBOL: unhandled-intervals
  27
  28 : add-unhandled ( live-interval -- )
  29     dup start>> unhandled-intervals get heap-push ;
  30
  31 : init-unhandled ( live-intervals -- )
  32     [ add-unhandled ] each ;
  33
  34 ! Mapping from basic blocks to values which are live at the start
  35 SYMBOL: register-live-ins
  36
  37 ! Mapping from basic blocks to values which are live at the end
  38 SYMBOL: register-live-outs
  39
  40 : init-assignment ( live-intervals -- )
  41     <min-heap> pending-intervals set
  42     <min-heap> unhandled-intervals set
  43     H{ } clone register-live-ins set
  44     H{ } clone register-live-outs set
  45     init-unhandled ;
  46
  47 : handle-spill ( live-interval -- )
  48     dup spill-to>> [
  49         [ reg>> ] [ spill-to>> <spill-slot> ] [ vreg>> reg-class>> ] tri
  50         register->memory
  51     ] [ drop ] if ;
  52
  53 : first-split ( live-interval -- live-interval' )
  54     dup split-before>> [ first-split ] [ ] ?if ;
  55
  56 : next-interval ( live-interval -- live-interval' )
  57     split-next>> first-split ;
  58
  59 : handle-copy ( live-interval -- )
  60     dup split-next>> [
  61         [ reg>> ] [ next-interval reg>> ] [ vreg>> reg-class>> ] tri
  62         register->register
  63     ] [ drop ] if ;
  64
  65 : (expire-old-intervals) ( n heap -- )
  66     dup heap-empty? [ 2drop ] [
  67         2dup heap-peek nip <= [ 2drop ] [
  68             dup heap-pop drop [ handle-spill ] [ handle-copy ] bi
  69             (expire-old-intervals)
  70         ] if
  71     ] if ;
  72
  73 : expire-old-intervals ( n -- )
  74     [
  75         pending-intervals get (expire-old-intervals)
  76     ] { } make mapping-instructions % ;
  77
  78 : insert-reload ( live-interval -- )
  79     {
  80         [ reg>> ]
  81         [ vreg>> reg-class>> ]
  82         [ reload-from>> ]
  83         [ start>> ]
  84     } cleave f swap \ _reload boa , ;
  85
  86 : handle-reload ( live-interval -- )
  87     dup reload-from>> [ insert-reload ] [ drop ] if ;
  88
  89 : activate-new-intervals ( n -- )
  90     #! Any live intervals which start on the current instruction
  91     #! are added to the active set.
  92     unhandled-intervals get dup heap-empty? [ 2drop ] [
  93         2dup heap-peek drop start>> = [
  94             heap-pop drop
  95             [ add-active ] [ handle-reload ] bi
  96             activate-new-intervals
  97         ] [ 2drop ] if
  98     ] if ;
  99
 100 : prepare-insn ( n -- )
 101     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 102
 103 GENERIC: assign-registers-in-insn ( insn -- )
 104
 105 : register-mapping ( live-intervals -- alist )
 106     [ [ vreg>> ] [ reg>> ] bi ] H{ } map>assoc ;
 107
 108 : all-vregs ( insn -- vregs )
 109     [ defs-vregs ] [ temp-vregs ] [ uses-vregs ] tri 3append ;
 110
 111 SYMBOL: check-assignment?
 112
 113 ERROR: overlapping-registers intervals ;
 114
 115 : check-assignment ( intervals -- )
 116     dup [ copy-from>> ] map sift '[ vreg>> _ member? not ] filter
 117     dup [ reg>> ] map all-unique? [ drop ] [ overlapping-registers ] if ;
 118
 119 : active-intervals ( n -- intervals )
 120     pending-intervals get heap-values [ covers? ] with filter
 121     check-assignment? get [ dup check-assignment ] when ;
 122
 123 M: vreg-insn assign-registers-in-insn
 124     dup [ all-vregs ] [ insn#>> active-intervals register-mapping ] bi
 125     extract-keys >>regs drop ;
 126
 127 M: ##gc assign-registers-in-insn
 128     ! This works because ##gc is always the first instruction
 129     ! in a block.
 130     dup call-next-method
 131     basic-block get register-live-ins get at >>live-values
 132     drop ;
 133
 134 M: insn assign-registers-in-insn drop ;
 135
 136 : compute-live-spill-slots ( vregs -- assoc )
 137     spill-slots get '[ _ at dup [ <spill-slot> ] when ] assoc-map ;
 138
 139 : compute-live-registers ( n -- assoc )
 140     active-intervals register-mapping ;
 141
 142 ERROR: bad-live-values live-values ;
 143
 144 : check-live-values ( assoc -- assoc )
 145     check-assignment? get [
 146         dup values [ not ] any? [ bad-live-values ] when
 147     ] when ;
 148
 149 : compute-live-values ( vregs n -- assoc )
 150     ! If a live vreg is not in active or inactive, then it must have been
 151     ! spilled.
 152     [ compute-live-spill-slots ] [ compute-live-registers ] bi*
 153     assoc-union check-live-values ;
 154
 155 : begin-block ( bb -- )
 156     dup basic-block set
 157     dup block-from activate-new-intervals
 158     [ [ live-in ] [ block-from ] bi compute-live-values ] keep
 159     register-live-ins get set-at ;
 160
 161 : end-block ( bb -- )
 162     [ [ live-out ] [ block-to ] bi compute-live-values ] keep
 163     register-live-outs get set-at ;
 164
 165 ERROR: bad-vreg vreg ;
 166
 167 : vreg-at-start ( vreg bb -- state )
 168     register-live-ins get at ?at [ bad-vreg ] unless ;
 169
 170 : vreg-at-end ( vreg bb -- state )
 171     register-live-outs get at ?at [ bad-vreg ] unless ;
 172
 173 :: assign-registers-in-block ( bb -- )
 174     bb [
 175         [
 176             bb begin-block
 177             [
 178                 {
 179                     [ insn#>> 1 - prepare-insn ]
 180                     [ insn#>> prepare-insn ]
 181                     [ assign-registers-in-insn ]
 182                     [ , ]
 183                 } cleave
 184             ] each
 185             bb end-block
 186         ] V{ } make
 187     ] change-instructions drop ;
 188
 189 : assign-registers ( live-intervals cfg -- )
 190     [ init-assignment ] dip
 191     [ assign-registers-in-block ] each-basic-block ;