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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors assocs binary-search combinators
   4 combinators.short-circuit heaps kernel namespaces
   5 sequences fry locals math math.order arrays sorting
   6 compiler.utilities
   7 compiler.cfg.linear-scan.live-intervals
   8 compiler.cfg.linear-scan.allocation.spilling
   9 compiler.cfg.linear-scan.allocation.splitting
  10 compiler.cfg.linear-scan.allocation.state ;
  11 IN: compiler.cfg.linear-scan.allocation
  12
  13 : active-positions ( new assoc -- )
  14     [ active-intervals-for ] dip
  15     '[ [ 0 ] dip reg>> _ add-use-position ] each ;
  16
  17 : inactive-positions ( new assoc -- )
  18     [ [ inactive-intervals-for ] keep ] dip
  19     '[
  20         [ _ relevant-ranges intersect-live-ranges 1/0. or ] [ reg>> ] bi
  21         _ add-use-position
  22     ] each ;
  23
  24 : register-status ( new -- free-pos )
  25     dup free-positions
  26     [ inactive-positions ] [ active-positions ] [ nip ] 2tri
  27     >alist alist-max ;
  28
  29 : no-free-registers? ( result -- ? )
  30     second 0 = ; inline
  31
  32 : assign-register ( new -- )
  33     dup register-status {
  34         { [ dup no-free-registers? ] [ drop assign-blocked-register ] }
  35         { [ 2dup register-available? ] [ register-available ] }
  36         [ drop assign-blocked-register ]
  37     } cond ;
  38
  39 : spill-at-sync-point? ( sync-point live-interval -- ? )
  40     ! If the live interval has a definition at a keep-dst?
  41     ! sync-point, don't spill.
  42     {
  43         [ drop keep-dst?>> not ]
  44         [ [ n>> ] dip find-use dup [ def-rep>> ] when not ]
  45     } 2|| ;
  46
  47 : spill-at-sync-point ( sync-point live-interval -- ? )
  48     2dup spill-at-sync-point?
  49     [ swap n>> spill f ] [ 2drop t ] if ;
  50
  51 GENERIC: handle-progress* ( obj -- )
  52
  53 M: live-interval handle-progress* drop ;
  54
  55 M: sync-point handle-progress*
  56     active-intervals get values
  57     [ [ spill-at-sync-point ] with filter! drop ] with each ;
  58
  59 :: handle-progress ( n obj -- )
  60     n progress set
  61     n deactivate-intervals
  62     obj handle-progress*
  63     n activate-intervals ;
  64
  65 GENERIC: handle ( obj -- )
  66
  67 M: live-interval handle ( live-interval -- )
  68     [ [ start>> ] keep handle-progress ] [ assign-register ] bi ;
  69
  70 M: sync-point handle ( sync-point -- )
  71     [ n>> ] keep handle-progress ;
  72
  73 : smallest-heap ( heap1 heap2 -- heap )
  74     ! If heap1 and heap2 have the same key, favors heap1.
  75     {
  76         { [ dup heap-empty? ] [ drop ] }
  77         { [ over heap-empty? ] [ nip ] }
  78         [ [ [ heap-peek nip ] bi@ <= ] most ]
  79     } cond ;
  80
  81 : (allocate-registers) ( -- )
  82     unhandled-intervals get unhandled-sync-points get smallest-heap
  83     dup heap-empty? [ drop ] [ heap-pop drop handle (allocate-registers) ] if ;
  84
  85 : finish-allocation ( -- )
  86     active-intervals inactive-intervals
  87     [ get values [ handled-intervals get push-all ] each ] bi@ ;
  88
  89 : allocate-registers ( live-intervals sync-point machine-registers -- live-intervals )
  90     init-allocator
  91     init-unhandled
  92     (allocate-registers)
  93     finish-allocation
  94     handled-intervals get ;