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     vreg pending at* [
  38         drop vreg vreg rep-of lookup-spill-slot
  39     ] unless ;
  40
  41 : vreg>reg ( vreg -- reg )
  42     pending-interval-assoc get (vreg>reg) ;
  43
  44 : vregs>regs ( vregs -- assoc )
  45     dup assoc-empty? [
  46         pending-interval-assoc get
  47         '[ _ (vreg>reg) ] assoc-map
  48     ] unless ;
  49
  50 ! Minheap of live intervals which still need a register allocation
  51 SYMBOL: unhandled-intervals
  52
  53 : add-unhandled ( live-interval -- )
  54     dup start>> unhandled-intervals get heap-push ;
  55
  56 : init-unhandled ( live-intervals -- )
  57     [ add-unhandled ] each ;
  58
  59 ! Mapping from basic blocks to values which are live at the start
  60 SYMBOL: register-live-ins
  61
  62 ! Mapping from basic blocks to values which are live at the end
  63 SYMBOL: register-live-outs
  64
  65 : init-assignment ( live-intervals -- )
  66     <min-heap> pending-interval-heap set
  67     H{ } clone pending-interval-assoc set
  68     <min-heap> unhandled-intervals set
  69     H{ } clone register-live-ins set
  70     H{ } clone register-live-outs set
  71     init-unhandled ;
  72
  73 : insert-spill ( live-interval -- )
  74     [ reg>> ] [ first-use rep>> ] [ spill-to>> ] tri ##spill ;
  75
  76 : handle-spill ( live-interval -- )
  77     dup spill-to>> [ insert-spill ] [ drop ] if ;
  78
  79 : expire-interval ( live-interval -- )
  80     [ remove-pending ] [ handle-spill ] bi ;
  81
  82 : (expire-old-intervals) ( n heap -- )
  83     dup heap-empty? [ 2drop ] [
  84         2dup heap-peek nip <= [ 2drop ] [
  85             dup heap-pop drop expire-interval
  86             (expire-old-intervals)
  87         ] if
  88     ] if ;
  89
  90 : expire-old-intervals ( n -- )
  91     pending-interval-heap get (expire-old-intervals) ;
  92
  93 : insert-reload ( live-interval -- )
  94     [ reg>> ] [ first-use rep>> ] [ reload-from>> ] tri ##reload ;
  95
  96 : insert-reload? ( live-interval -- ? )
  97     ! Don't insert a reload if the register will be written to
  98     ! before being read again.
  99     {
 100         [ reload-from>> ]
 101         [ first-use type>> +use+ eq? ]
 102     } 1&& ;
 103
 104 : handle-reload ( live-interval -- )
 105     dup insert-reload? [ insert-reload ] [ drop ] if ;
 106
 107 : activate-interval ( live-interval -- )
 108     [ add-pending ] [ handle-reload ] bi ;
 109
 110 : (activate-new-intervals) ( n heap -- )
 111     dup heap-empty? [ 2drop ] [
 112         2dup heap-peek nip = [
 113             dup heap-pop drop activate-interval
 114             (activate-new-intervals)
 115         ] [ 2drop ] if
 116     ] if ;
 117
 118 : activate-new-intervals ( n -- )
 119     unhandled-intervals get (activate-new-intervals) ;
 120
 121 : prepare-insn ( n -- )
 122     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
 123
 124 GENERIC: assign-registers-in-insn ( insn -- )
 125
 126 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 127
 128 M: vreg-insn assign-registers-in-insn
 129     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 130
 131 M: ##call-gc assign-registers-in-insn
 132     dup call-next-method
 133     [ [ vreg>reg ] map ] change-gc-roots drop ;
 134
 135 M: insn assign-registers-in-insn drop ;
 136
 137 : begin-block ( bb -- )
 138     dup basic-block set
 139     dup block-from activate-new-intervals
 140     [ live-in vregs>regs ] keep register-live-ins get set-at ;
 141
 142 : end-block ( bb -- )
 143     [ live-out vregs>regs ] keep register-live-outs get set-at ;
 144
 145 : vreg-at-start ( vreg bb -- state )
 146     register-live-ins get at ?at [ bad-vreg ] unless ;
 147
 148 : vreg-at-end ( vreg bb -- state )
 149     register-live-outs get at ?at [ bad-vreg ] unless ;
 150
 151 :: assign-registers-in-block ( bb -- )
 152     bb [
 153         [
 154             bb begin-block
 155             [
 156                 {
 157                     [ insn#>> 1 - prepare-insn ]
 158                     [ insn#>> prepare-insn ]
 159                     [ assign-registers-in-insn ]
 160                     [ , ]
 161                 } cleave
 162             ] each
 163             bb end-block
 164         ] V{ } make
 165     ] change-instructions drop ;
 166
 167 : assign-registers ( live-intervals cfg -- )
 168     [ init-assignment ] dip
 169     linearization-order [ assign-registers-in-block ] each ;