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

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators compiler.cfg
   4 compiler.cfg.instructions
   5 compiler.cfg.linear-scan.live-intervals compiler.cfg.registers
   6 cpu.architecture fry heaps kernel math math.order namespaces sequences ;
   7 IN: compiler.cfg.linear-scan.allocation.state
   8
   9 SYMBOL: progress
  10
  11 : check-unhandled ( live-interval -- )
  12     start>> progress get <= [ "check-unhandled" throw ] when ; inline
  13
  14 : check-handled ( live-interval -- )
  15     end>> progress get > [ "check-handled" throw ] when ; inline
  16
  17 SYMBOL: unhandled-min-heap
  18
  19 GENERIC: interval/sync-point-key ( interval/sync-point -- key )
  20
  21 M: live-interval-state interval/sync-point-key
  22     [ start>> ] [ end>> ] [ vreg>> ] tri 3array ;
  23
  24 M: sync-point interval/sync-point-key
  25     n>> 1/0. 1/0. 3array ;
  26
  27 : >unhandled-min-heap ( intervals/sync-points -- min-heap )
  28     [ [ interval/sync-point-key ] keep 2array ] map >min-heap ;
  29
  30 SYMBOL: registers
  31
  32 SYMBOL: active-intervals
  33
  34 : active-intervals-for ( live-interval -- seq )
  35     reg-class>> active-intervals get at ;
  36
  37 : add-active ( live-interval -- )
  38     dup active-intervals-for push ;
  39
  40 : delete-active ( live-interval -- )
  41     dup active-intervals-for remove-eq! drop ;
  42
  43 : assign-free-register ( new registers -- )
  44     pop >>reg add-active ;
  45
  46 SYMBOL: inactive-intervals
  47
  48 : inactive-intervals-for ( live-interval -- seq )
  49     reg-class>> inactive-intervals get at ;
  50
  51 : add-inactive ( live-interval -- )
  52     dup inactive-intervals-for push ;
  53
  54 : delete-inactive ( live-interval -- )
  55     dup inactive-intervals-for remove-eq! drop ;
  56
  57 SYMBOL: handled-intervals
  58
  59 : add-handled ( live-interval -- )
  60     [ check-handled ] [ handled-intervals get push ] bi ;
  61
  62 : finished? ( n live-interval -- ? ) end>> swap < ;
  63
  64 : finish ( n live-interval -- keep? )
  65     nip add-handled f ;
  66
  67 SYMBOL: check-allocation?
  68
  69 ERROR: register-already-used live-interval ;
  70
  71 : check-activate ( live-interval -- )
  72     check-allocation? get [
  73         dup [ reg>> ] [ active-intervals-for [ reg>> ] map ] bi member?
  74         [ register-already-used ] [ drop ] if
  75     ] [ drop ] if ;
  76
  77 : activate ( n live-interval -- keep? )
  78     dup check-activate
  79     nip add-active f ;
  80
  81 : deactivate ( n live-interval -- keep? )
  82     nip add-inactive f ;
  83
  84 : don't-change ( n live-interval -- keep? ) 2drop t ;
  85
  86 ! Moving intervals between active and inactive sets
  87 : process-intervals ( n symbol quots -- )
  88     ! symbol stores an alist mapping register classes to vectors
  89     [ get values ] dip '[ [ _ cond ] with filter! drop ] with each ; inline
  90
  91 : deactivate-intervals ( n -- )
  92     dup progress set
  93     active-intervals {
  94         { [ 2dup finished? ] [ finish ] }
  95         { [ 2dup covers? not ] [ deactivate ] }
  96         [ don't-change ]
  97     } process-intervals ;
  98
  99 : activate-intervals ( n -- )
 100     inactive-intervals {
 101         { [ 2dup finished? ] [ finish ] }
 102         { [ 2dup covers? ] [ activate ] }
 103         [ don't-change ]
 104     } process-intervals ;
 105
 106 : add-unhandled ( live-interval -- )
 107     dup check-unhandled
 108     dup interval/sync-point-key unhandled-min-heap get heap-push ;
 109
 110 : reg-class-assoc ( quot -- assoc )
 111     [ reg-classes ] dip { } map>assoc ; inline
 112
 113 : next-spill-slot ( size -- spill-slot )
 114     cfg get
 115     [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop
 116     <spill-slot> ;
 117
 118 : align-spill-area ( align cfg -- )
 119     [ max ] change-spill-area-align drop ;
 120
 121 SYMBOL: spill-slots
 122
 123 : assign-spill-slot ( coalesced-vreg rep -- spill-slot )
 124     rep-size
 125     [ cfg get align-spill-area ]
 126     [ spill-slots get [ nip next-spill-slot ] 2cache ]
 127     bi ;
 128
 129 : lookup-spill-slot ( coalesced-vreg rep -- spill-slot )
 130     rep-size 2array spill-slots get ?at [ ] [ bad-vreg ] if ;
 131
 132 : init-allocator ( intervals/sync-points registers -- )
 133     registers set
 134     >unhandled-min-heap unhandled-min-heap set
 135     [ V{ } clone ] reg-class-assoc active-intervals set
 136     [ V{ } clone ] reg-class-assoc inactive-intervals set
 137     V{ } clone handled-intervals set
 138     H{ } clone spill-slots set
 139     -1 progress set ;
 140
 141 : add-use-position ( n reg assoc -- )
 142     [ [ min ] when* ] change-at ;
 143
 144 : register-available? ( new result -- ? )
 145     [ end>> ] [ second ] bi* < ; inline
 146
 147 : register-available ( new result -- )
 148     first >>reg add-active ;