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

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