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