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 arrays
   5 cpu.architecture
   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 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-interval-heap
  21 SYMBOL: pending-interval-assoc
  22
  23 : add-pending ( live-interval -- )
  24     [ dup end>> pending-interval-heap get heap-push ]
  25     [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
  26     bi ;
  27
  28 : remove-pending ( live-interval -- )
  29     vreg>> pending-interval-assoc get delete-at ;
  30
  31 ERROR: bad-vreg vreg ;
  32
  33 : (vreg>reg) ( vreg pending -- reg )
  34     ! If a live vreg is not in the pending set, then it must
  35     ! have been spilled.
  36     ?at [ spill-slots get ?at [ <spill-slot> ] [ bad-vreg ] if ] unless ;
  37
  38 : vreg>reg ( vreg -- reg )
  39     pending-interval-assoc get (vreg>reg) ;
  40
  41 : vregs>regs ( vregs -- assoc )
  42     dup assoc-empty? [
  43         pending-interval-assoc get
  44         '[ _ (vreg>reg) ] assoc-map
  45     ] unless ;
  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 ! Mapping from basic blocks to values which are live at the start
  57 SYMBOL: register-live-ins
  58
  59 ! Mapping from basic blocks to values which are live at the end
  60 SYMBOL: register-live-outs
  61
  62 : init-assignment ( live-intervals -- )
  63     <min-heap> pending-interval-heap set
  64     H{ } clone pending-interval-assoc set
  65     <min-heap> unhandled-intervals set
  66     H{ } clone register-live-ins set
  67     H{ } clone register-live-outs set
  68     init-unhandled ;
  69
  70 : insert-spill ( live-interval -- )
  71     [ reg>> ] [ vreg>> rep-of ] [ spill-to>> ] tri _spill ;
  72
  73 : handle-spill ( live-interval -- )
  74     dup spill-to>> [ insert-spill ] [ drop ] if ;
  75
  76 : expire-interval ( live-interval -- )
  77     [ remove-pending ] [ handle-spill ] bi ;
  78
  79 : (expire-old-intervals) ( n heap -- )
  80     dup heap-empty? [ 2drop ] [
  81         2dup heap-peek nip <= [ 2drop ] [
  82             dup heap-pop drop expire-interval
  83             (expire-old-intervals)
  84         ] if
  85     ] if ;
  86
  87 : expire-old-intervals ( n -- )
  88     pending-interval-heap get (expire-old-intervals) ;
  89
  90 : insert-reload ( live-interval -- )
  91     [ reg>> ] [ vreg>> rep-of ] [ reload-from>> ] tri _reload ;
  92
  93 : handle-reload ( live-interval -- )
  94     dup reload-from>> [ insert-reload ] [ drop ] if ;
  95
  96 : activate-interval ( live-interval -- )
  97     [ add-pending ] [ handle-reload ] bi ;
  98
  99 : (activate-new-intervals) ( n heap -- )
 100     dup heap-empty? [ 2drop ] [
 101         2dup heap-peek nip = [
 102             dup heap-pop drop activate-interval
 103             (activate-new-intervals)
 104         ] [ 2drop ] if
 105     ] if ;
 106
 107 : activate-new-intervals ( n -- )
 108     unhandled-intervals get (activate-new-intervals) ;
 109
 110 : prepare-insn ( n -- )
 111     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 112
 113 GENERIC: assign-registers-in-insn ( insn -- )
 114
 115 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 116
 117 M: vreg-insn assign-registers-in-insn
 118     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 119
 120 ! TODO: needs tagged-rep
 121
 122 : trace-on-gc ( assoc -- assoc' )
 123     ! When a GC occurs, virtual registers which contain tagged data
 124     ! are traced by the GC. Outputs a sequence physical registers.
 125     [ drop rep-of int-rep eq? ] { } assoc-filter-as values ;
 126
 127 : spill-on-gc? ( vreg reg -- ? )
 128     [ rep-of int-rep? not ] [ spill-slot? not ] bi* and ;
 129
 130 : spill-on-gc ( assoc -- assoc' )
 131     ! When a GC occurs, virtual registers which contain untagged data,
 132     ! and are stored in physical registers, are saved to their spill
 133     ! slots. Outputs sequence of triples:
 134     ! - physical register
 135     ! - spill slot
 136     ! - representation
 137     [
 138         [
 139             2dup spill-on-gc?
 140             [ swap [ rep-of ] [ vreg-spill-slot ] bi 3array , ] [ 2drop ] if
 141         ] assoc-each
 142     ] { } make ;
 143
 144 M: ##gc assign-registers-in-insn
 145     ! Since ##gc is always the first instruction in a block, the set of
 146     ! values live at the ##gc is just live-in.
 147     dup call-next-method
 148     basic-block get register-live-ins get at
 149     [ trace-on-gc >>tagged-values ] [ spill-on-gc >>data-values ] bi
 150     drop ;
 151
 152 M: insn assign-registers-in-insn drop ;
 153
 154 : begin-block ( bb -- )
 155     dup basic-block set
 156     dup block-from activate-new-intervals
 157     [ live-in vregs>regs ] keep register-live-ins get set-at ;
 158
 159 : end-block ( bb -- )
 160     [ live-out vregs>regs ] keep register-live-outs get set-at ;
 161
 162 : vreg-at-start ( vreg bb -- state )
 163     register-live-ins get at ?at [ bad-vreg ] unless ;
 164
 165 : vreg-at-end ( vreg bb -- state )
 166     register-live-outs get at ?at [ bad-vreg ] unless ;
 167
 168 :: assign-registers-in-block ( bb -- )
 169     bb [
 170         [
 171             bb begin-block
 172             [
 173                 {
 174                     [ insn#>> 1 - prepare-insn ]
 175                     [ insn#>> prepare-insn ]
 176                     [ assign-registers-in-insn ]
 177                     [ , ]
 178                 } cleave
 179             ] each
 180             bb end-block
 181         ] V{ } make
 182     ] change-instructions drop ;
 183
 184 : assign-registers ( live-intervals cfg -- )
 185     [ init-assignment ] dip
 186     linearization-order [ assign-registers-in-block ] each ;