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

   1 ! Copyright (C) 2009, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs combinators
   4 compiler.cfg.linear-scan.allocation.splitting
   5 compiler.cfg.linear-scan.allocation.state
   6 compiler.cfg.linear-scan.live-intervals compiler.cfg.registers
   7 compiler.utilities fry kernel linked-assocs locals math namespaces sequences ;
   8 IN: compiler.cfg.linear-scan.allocation.spilling
   9
  10 ERROR: bad-live-ranges interval ;
  11
  12 : check-ranges ( live-interval -- )
  13     check-allocation? get [
  14         dup ranges>> [ [ from>> ] [ to>> ] bi <= ] all?
  15         [ drop ] [ throw-bad-live-ranges ] if
  16     ] [ drop ] if ;
  17
  18 : trim-before-ranges ( live-interval -- )
  19     dup last-use n>> 1 +
  20     [ '[ [ from>> _ >= ] trim-tail-slice ] change-ranges drop ]
  21     [ swap ranges>> last to<< ]
  22     2bi ;
  23
  24 : trim-after-ranges ( live-interval -- )
  25     dup first-use n>>
  26     [ '[ [ to>> _ < ] trim-head-slice ] change-ranges drop ]
  27     [ swap ranges>> first from<< ]
  28     2bi ;
  29
  30 : last-use-rep ( live-interval -- rep/f )
  31     last-use [ def-rep>> ] [ use-rep>> ] bi or ; inline
  32
  33 : assign-spill ( live-interval -- )
  34     dup last-use-rep dup [
  35         >>spill-rep
  36         dup [ vreg>> ] [ spill-rep>> ] bi
  37         assign-spill-slot >>spill-to drop
  38     ] [ 2drop ] if ;
  39
  40 : spill-before ( before -- before/f )
  41     dup uses>> empty? [ drop f ] [
  42         {
  43             [ ]
  44             [ assign-spill ]
  45             [ trim-before-ranges ]
  46             [ compute-start/end ]
  47             [ check-ranges ]
  48         } cleave
  49     ] if ;
  50
  51 : first-use-rep ( live-interval -- rep/f )
  52     first-use use-rep>> ; inline
  53
  54 : assign-reload ( live-interval -- )
  55     dup first-use-rep dup [
  56         >>reload-rep
  57         dup [ vreg>> ] [ reload-rep>> ] bi
  58         assign-spill-slot >>reload-from drop
  59     ] [ 2drop ] if ;
  60
  61 : spill-after ( after -- after/f )
  62     dup uses>> empty? [ drop f ] [
  63         {
  64             [ ]
  65             [ assign-reload ]
  66             [ trim-after-ranges ]
  67             [ compute-start/end ]
  68             [ check-ranges ]
  69         } cleave
  70     ] if ;
  71
  72 : split-for-spill ( live-interval n -- before after )
  73     split-interval [ spill-before ] [ spill-after ] bi* ;
  74
  75 : find-next-use ( live-interval new -- n )
  76     [ uses>> ] [ start>> ] bi*
  77     '[ [ spill-slot?>> not ] [ n>> ] bi _ >= and ] find nip
  78     [ n>> ] [ 1/0. ] if* ;
  79
  80 : find-use-positions ( live-intervals new assoc -- )
  81     '[ [ _ find-next-use ] [ reg>> ] bi _ add-use-position ] each ;
  82
  83 : active-positions ( new assoc -- )
  84     [ [ active-intervals-for ] keep ] dip
  85     find-use-positions ;
  86
  87 : inactive-positions ( new assoc -- )
  88     [
  89         [ inactive-intervals-for ] keep
  90         [ '[ _ intervals-intersect? ] filter ] keep
  91     ] dip
  92     find-use-positions ;
  93
  94 : spill-status ( new -- use-pos )
  95     H{ } <linked-assoc>
  96     [ inactive-positions ] [ active-positions ] [ nip ] 2tri
  97     >alist alist-max ;
  98
  99 : spill-new? ( new pair -- ? )
 100     [ first-use n>> ] [ second ] bi* > ;
 101
 102 : spill-new ( new pair -- )
 103     drop spill-after add-unhandled ;
 104
 105 : spill ( live-interval n -- )
 106     split-for-spill
 107     [ [ add-handled ] when* ]
 108     [ [ add-unhandled ] when* ] bi* ;
 109
 110 :: spill-intersecting-active ( new reg -- )
 111     new active-intervals-for [ [ reg>> reg = ] find swap dup ] keep
 112     '[ _ remove-nth! drop  new start>> spill ] [ 2drop ] if ;
 113
 114 :: spill-intersecting-inactive ( new reg -- )
 115     new inactive-intervals-for [
 116         dup reg>> reg = [
 117             dup new intervals-intersect? [
 118                 new start>> spill f
 119             ] [ drop t ] if
 120         ] [ drop t ] if
 121     ] filter! drop ;
 122
 123 : spill-intersecting ( new reg -- )
 124     [ spill-intersecting-active ]
 125     [ spill-intersecting-inactive ]
 126     2bi ;
 127
 128 : spill-available ( new pair -- )
 129     [ first spill-intersecting ] [ register-available ] 2bi ;
 130
 131 : spill-partially-available ( new pair -- )
 132     [ second 1 - split-for-spill [ add-unhandled ] when* ] keep
 133     '[ _ spill-available ] when* ;
 134
 135 : assign-blocked-register ( live-interval -- )
 136     dup spill-status {
 137         { [ 2dup spill-new? ] [ spill-new ] }
 138         { [ 2dup register-available? ] [ spill-available ] }
 139         [ spill-partially-available ]
 140     } cond ;