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

   1 ! Copyright (C) 2008, 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.allocation.state
   5 compiler.cfg.linear-scan.live-intervals
   6 compiler.cfg.linearization compiler.cfg.liveness
   7 compiler.cfg.registers compiler.cfg.renaming.functor
   8 compiler.cfg.ssa.destruction.leaders compiler.cfg.utilities
   9 heaps kernel make math namespaces sequences ;
  10 IN: compiler.cfg.linear-scan.assignment
  11 QUALIFIED: sets
  12
  13 ! This contains both active and inactive intervals; any interval
  14 ! such that start <= insn# <= end is in this set.
  15 SYMBOL: pending-interval-heap
  16 SYMBOL: pending-interval-assoc
  17
  18 : insert-spill ( live-interval -- )
  19     [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
  20
  21 : handle-spill ( live-interval -- )
  22     dup spill-to>> [ insert-spill ] [ drop ] if ;
  23
  24 : add-pending ( live-interval -- )
  25     [ dup live-interval-end pending-interval-heap get heap-push ]
  26     [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
  27     bi ;
  28
  29 : remove-pending ( live-interval -- )
  30     vreg>> pending-interval-assoc get delete-at ;
  31
  32 : vreg>spill-slot ( vreg -- spill-slot )
  33     dup rep-of lookup-spill-slot ;
  34
  35 : vreg>reg ( vreg -- reg/spill-slot )
  36     dup leader dup pending-interval-assoc get at
  37     [ 2nip ] [ swap rep-of lookup-spill-slot ] if* ;
  38
  39 : vregs>regs ( assoc -- assoc' )
  40     [ vreg>reg ] assoc-map ;
  41
  42 SYMBOL: unhandled-intervals
  43
  44 SYMBOL: machine-live-ins
  45
  46 : machine-live-in ( bb -- assoc )
  47     machine-live-ins get at ;
  48
  49 : compute-live-in ( bb -- )
  50     [ live-in vregs>regs ] keep machine-live-ins get set-at ;
  51
  52 SYMBOL: machine-edge-live-ins
  53
  54 : machine-edge-live-in ( predecessor bb -- assoc )
  55     machine-edge-live-ins get at at ;
  56
  57 : compute-edge-live-in ( bb -- )
  58     [ edge-live-ins get at [ vregs>regs ] assoc-map ] keep
  59     machine-edge-live-ins get set-at ;
  60
  61 SYMBOL: machine-live-outs
  62
  63 : machine-live-out ( bb -- assoc )
  64     machine-live-outs get at ;
  65
  66 : compute-live-out ( bb -- )
  67     [ live-out vregs>regs ] keep machine-live-outs get set-at ;
  68
  69 : expire-interval ( live-interval -- )
  70     [ remove-pending ] [ handle-spill ] bi ;
  71
  72 : expire-old-intervals ( n pending-heap -- )
  73     [ > ] with heap-pop-while [ expire-interval ] each ;
  74
  75 : insert-reload ( live-interval -- )
  76     [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
  77
  78 : handle-reload ( live-interval -- )
  79     dup reload-from>> [ insert-reload ] [ drop ] if ;
  80
  81 : activate-interval ( live-interval -- )
  82     [ add-pending ] [ handle-reload ] bi ;
  83
  84 : activate-new-intervals ( n unhandled-heap -- )
  85     [ = ] with heap-pop-while [ activate-interval ] each ;
  86
  87 : prepare-insn ( n -- )
  88     [ pending-interval-heap get expire-old-intervals ]
  89     [ unhandled-intervals get activate-new-intervals ] bi ;
  90
  91 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
  92
  93 : assign-all-registers ( insn -- )
  94     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
  95
  96 : begin-block ( bb -- )
  97     {
  98         [ basic-block namespaces:set ]
  99         [ block-from unhandled-intervals get activate-new-intervals ]
 100         [ compute-edge-live-in ]
 101         [ compute-live-in ]
 102     } cleave ;
 103
 104 : change-insn-gc-roots ( gc-map-insn quot: ( x -- x ) -- )
 105     [ gc-map>> ] dip [ [ gc-roots>> ] dip map! drop ]
 106     [ '[ [ _ bi@ ] assoc-map ] change-derived-roots drop ] 2bi ; inline
 107
 108 : spill-required? ( live-interval root-leaders n -- ? )
 109     [ [ vreg>> ] dip sets:in? ] [ swap covers? ] bi-curry* bi or ;
 110
 111 : spill-intervals ( root-leaders n -- live-intervals )
 112     [ pending-interval-heap get heap-members ] 2dip
 113     '[ _ _ spill-required? ] filter ;
 114
 115 : rep-at-insn ( n interval -- rep )
 116     (find-use) [ def-rep>> ] [ use-rep>> ] bi or ;
 117
 118 : spill/reload ( n interval -- {reg,rep,slot} )
 119     [ rep-at-insn ] keep [ reg>> ] [ vreg>> ] bi
 120     pick assign-spill-slot swapd 3array ;
 121
 122 : spill/reloads ( n intervals -- spill/reloads )
 123     [ spill/reload ] with map ;
 124
 125 : spill/reloads-for-call-gc ( ##call-gc -- spill-seq )
 126     [ gc-map>> gc-roots>> ] [ insn#>> ] bi
 127     [ spill-intervals ] keep swap spill/reloads ;
 128
 129 : emit-##call-gc ( insn -- )
 130     dup spill/reloads-for-call-gc
 131     dup [ first3 ##spill, ] each
 132     swap ,
 133     [ first3 ##reload, ] each ;
 134
 135 : emit-gc-map-insn ( gc-map-insn -- )
 136     [ [ leader ] change-insn-gc-roots ]
 137     [ dup ##call-gc? [ emit-##call-gc ] [ , ] if ]
 138     [ [ vreg>spill-slot ] change-insn-gc-roots ] tri ;
 139
 140 : emit-insn ( insn -- )
 141     dup gc-map-insn? [ emit-gc-map-insn ] [ , ] if ;
 142
 143 : assign-registers-in-block ( bb -- )
 144     dup begin-block
 145     [
 146         [
 147             [
 148                 [ insn#>> prepare-insn ]
 149                 [ assign-all-registers ]
 150                 [ emit-insn ] tri
 151             ] each
 152         ] V{ } make
 153     ] change-instructions compute-live-out ;
 154
 155 : live-intervals>min-heap ( live-intervals -- min-heap )
 156     [ [ live-interval-start ] map ] keep zip >min-heap ;
 157
 158 : init-assignment ( live-intervals -- )
 159     live-intervals>min-heap unhandled-intervals namespaces:set
 160     <min-heap> pending-interval-heap namespaces:set
 161     H{ } clone pending-interval-assoc namespaces:set
 162     H{ } clone machine-live-ins namespaces:set
 163     H{ } clone machine-edge-live-ins namespaces:set
 164     H{ } clone machine-live-outs namespaces:set ;
 165
 166 : assign-registers ( cfg live-intervals -- )
 167     init-assignment
 168     linearization-order [ kill-block?>> ] reject
 169     [ assign-registers-in-block ] each ;