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

   1 ! Copyright (C) 2008 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces sequences math math.order kernel assocs
   4 accessors vectors fry heaps cpu.architecture combinators
   5 compiler.cfg.registers
   6 compiler.cfg.linear-scan.live-intervals ;
   7 IN: compiler.cfg.linear-scan.allocation
   8
   9 ! Mapping from register classes to sequences of machine registers
  10 SYMBOL: free-registers
  11
  12 : free-registers-for ( vreg -- seq )
  13     reg-class>> free-registers get at ;
  14
  15 : deallocate-register ( live-interval -- )
  16     [ reg>> ] [ vreg>> ] bi free-registers-for push ;
  17
  18 ! Vector of active live intervals
  19 SYMBOL: active-intervals
  20
  21 : active-intervals-for ( vreg -- seq )
  22     reg-class>> active-intervals get at ;
  23
  24 : add-active ( live-interval -- )
  25     dup vreg>> active-intervals-for push ;
  26
  27 : delete-active ( live-interval -- )
  28     dup vreg>> active-intervals-for delq ;
  29
  30 : expire-old-intervals ( n -- )
  31     active-intervals swap '[
  32         [
  33             [ end>> _ < ] partition
  34             [ [ deallocate-register ] each ] dip
  35         ] assoc-map
  36     ] change ;
  37
  38 ! Minheap of live intervals which still need a register allocation
  39 SYMBOL: unhandled-intervals
  40
  41 ! Start index of current live interval. We ensure that all
  42 ! live intervals added to the unhandled set have a start index
  43 ! strictly greater than ths one. This ensures that we can catch
  44 ! infinite loop situations.
  45 SYMBOL: progress
  46
  47 : check-progress ( live-interval -- )
  48     start>> progress get <= [ "No progress" throw ] when ; inline
  49
  50 : add-unhandled ( live-interval -- )
  51     [ check-progress ]
  52     [ dup start>> unhandled-intervals get heap-push ]
  53     bi ;
  54
  55 : init-unhandled ( live-intervals -- )
  56     [ [ start>> ] keep ] { } map>assoc
  57     unhandled-intervals get heap-push-all ;
  58
  59 ! Coalescing
  60 : active-interval ( vreg -- live-interval )
  61     dup [ dup active-intervals-for [ vreg>> = ] with find nip ] when ;
  62
  63 : coalesce? ( live-interval -- ? )
  64     [ start>> ] [ copy-from>> active-interval ] bi
  65     dup [ end>> = ] [ 2drop f ] if ;
  66
  67 : coalesce ( live-interval -- )
  68     dup copy-from>> active-interval
  69     [ [ add-active ] [ delete-active ] bi* ]
  70     [ reg>> >>reg drop ]
  71     2bi ;
  72
  73 ! Splitting
  74 : find-use ( live-interval n quot -- i elt )
  75     [ uses>> ] 2dip curry find ; inline
  76
  77 : split-before ( live-interval i -- before )
  78     [ clone dup uses>> ] dip
  79     [ head >>uses ] [ 1- swap nth >>end ] 2bi ;
  80
  81 : split-after ( live-interval i -- after )
  82     [ clone dup uses>> ] dip
  83     [ tail >>uses ] [ swap nth >>start ] 2bi
  84     f >>reg f >>copy-from ;
  85
  86 : split-interval ( live-interval n -- before after )
  87     [ drop ] [ [ > ] find-use drop ] 2bi
  88     [ split-before ] [ split-after ] 2bi ;
  89
  90 : record-split ( live-interval before after -- )
  91     [ >>split-before ] [ >>split-after ] bi* drop ;
  92
  93 ! Spilling
  94 SYMBOL: spill-counts
  95
  96 : next-spill-location ( reg-class -- n )
  97     spill-counts get [ dup 1+ ] change-at ;
  98
  99 : interval-to-spill ( active-intervals current -- live-interval )
 100     #! We spill the interval with the most distant use location.
 101     start>> '[ dup _ [ >= ] find-use nip ] { } map>assoc
 102     unclip-slice [ [ [ second ] bi@ > ] most ] reduce first ;
 103
 104 : assign-spill ( before after -- before after )
 105     #! If it has been spilled already, reuse spill location.
 106     over reload-from>>
 107     [ over vreg>> reg-class>> next-spill-location ] unless*
 108     tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
 109
 110 : split-and-spill ( new existing -- before after )
 111     dup rot start>> split-interval
 112     [ record-split ] [ assign-spill ] 2bi ;
 113
 114 : reuse-register ( new existing -- )
 115     reg>> >>reg add-active ;
 116
 117 : spill-existing ( new existing -- )
 118     #! Our new interval will be used before the active interval
 119     #! with the most distant use location. Spill the existing
 120     #! interval, then process the new interval and the tail end
 121     #! of the existing interval again.
 122     [ reuse-register ]
 123     [ nip delete-active ]
 124     [ split-and-spill [ drop ] [ add-unhandled ] bi* ] 2tri ;
 125
 126 : spill-new ( new existing -- )
 127     #! Our new interval will be used after the active interval
 128     #! with the most distant use location. Split the new
 129     #! interval, then process both parts of the new interval
 130     #! again.
 131     [ dup split-and-spill add-unhandled ] dip spill-existing ;
 132
 133 : spill-existing? ( new existing -- ? )
 134     #! Test if 'new' will be used before 'existing'.
 135     over start>> '[ _ [ > ] find-use nip -1 or ] bi@ < ;
 136
 137 : assign-blocked-register ( new -- )
 138     [ dup vreg>> active-intervals-for ] keep interval-to-spill
 139     2dup spill-existing? [ spill-existing ] [ spill-new ] if ;
 140
 141 : assign-free-register ( new registers -- )
 142     pop >>reg add-active ;
 143
 144 : assign-register ( new -- )
 145     dup coalesce? [
 146         coalesce
 147     ] [
 148         dup vreg>> free-registers-for
 149         [ assign-blocked-register ]
 150         [ assign-free-register ]
 151         if-empty
 152     ] if ;
 153
 154 ! Main loop
 155 : reg-classes ( -- seq ) { int-regs double-float-regs } ; inline
 156
 157 : init-allocator ( registers -- )
 158     <min-heap> unhandled-intervals set
 159     [ reverse >vector ] assoc-map free-registers set
 160     reg-classes [ 0 ] { } map>assoc spill-counts set
 161     reg-classes [ V{ } clone ] { } map>assoc active-intervals set
 162     -1 progress set ;
 163
 164 : handle-interval ( live-interval -- )
 165     [ start>> progress set ]
 166     [ start>> expire-old-intervals ]
 167     [ assign-register ]
 168     tri ;
 169
 170 : (allocate-registers) ( -- )
 171     unhandled-intervals get [ handle-interval ] slurp-heap ;
 172
 173 : allocate-registers ( live-intervals machine-registers -- live-intervals )
 174     #! This modifies the input live-intervals.
 175     init-allocator
 176     dup init-unhandled
 177     (allocate-registers) ;