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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See https://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators
   4 combinators.short-circuit compiler.cfg.linear-scan.allocation.spilling
   5 compiler.cfg.linear-scan.allocation.state
   6 compiler.cfg.linear-scan.live-intervals compiler.utilities heaps
   7 kernel namespaces sequences ;
   8 IN: compiler.cfg.linear-scan.allocation
   9
  10 : active-positions ( new assoc -- )
  11     swap active-intervals-for [ reg>> 0 2array ] map assoc-union! drop ;
  12
  13 : inactive-positions ( new assoc -- )
  14     [ [ inactive-intervals-for ] keep ] dip
  15     '[
  16         [ _ intersect-intervals 1/0. or ] [ reg>> ] bi
  17         _ add-use-position
  18     ] each ;
  19
  20 : free-positions ( registers reg-class -- avail-registers )
  21     of [ 1/0. 2array ] map ;
  22
  23 : register-status ( new registers -- free-pos )
  24     over interval-reg-class free-positions [
  25         [ inactive-positions ] [ active-positions ] 2bi
  26     ] keep alist-max ;
  27
  28 : assign-register ( new registers -- )
  29     dupd register-status {
  30         { [ dup second 0 = ] [ drop assign-blocked-register ] }
  31         { [ 2dup register-available? ] [ register-available ] }
  32         [ drop assign-blocked-register ]
  33     } cond ;
  34
  35 : spill-at-sync-point? ( sync-point live-interval -- ? )
  36     {
  37         [ drop keep-dst?>> not ]
  38         [ [ n>> ] dip find-use [ def-rep>> ] ?call not ]
  39     } 2|| ;
  40
  41 : spill-at-sync-point ( sync-point live-interval -- ? )
  42     2dup spill-at-sync-point?
  43     [ swap n>> spill f ] [ 2drop t ] if ;
  44
  45 GENERIC: handle ( obj -- )
  46
  47 M: live-interval-state handle
  48     [
  49         live-interval-start
  50         [ deactivate-intervals ] [ activate-intervals ] bi
  51     ]
  52     [ registers get assign-register ] bi ;
  53
  54 : handle-sync-point ( sync-point active-intervals -- )
  55     values [ [ spill-at-sync-point ] with filter! drop ] with each ;
  56
  57 M: sync-point handle ( sync-point -- )
  58     [ n>> [ deactivate-intervals ] [ activate-intervals ] bi ]
  59     [ active-intervals get handle-sync-point ] bi ;
  60
  61 : (allocate-registers) ( unhandled-min-heap -- )
  62     [ drop handle ] slurp-heap ;
  63
  64 : gather-intervals ( -- live-intervals )
  65     handled-intervals get
  66     active-intervals inactive-intervals [ get values concat ] bi@ 3append ;
  67
  68 : allocate-registers ( intervals/sync-points registers -- live-intervals' )
  69     init-allocator unhandled-min-heap get (allocate-registers)
  70     gather-intervals ;