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

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs combinators compiler.cfg
   4 compiler.cfg.linearization compiler.cfg.liveness compiler.cfg.registers
   5 compiler.cfg.instructions compiler.cfg.linear-scan.allocation.state
   6 compiler.cfg.linear-scan.live-intervals compiler.cfg.renaming.functor
   7 compiler.cfg.ssa.destruction.leaders cpu.architecture
   8 fry heaps kernel make math namespaces sequences sets ;
   9 IN: compiler.cfg.linear-scan.assignment
  10
  11 ! This contains both active and inactive intervals; any interval
  12 ! such that start <= insn# <= end is in this set.
  13 SYMBOL: pending-interval-heap
  14 SYMBOL: pending-interval-assoc
  15
  16 : add-pending ( live-interval -- )
  17     [ dup end>> pending-interval-heap get heap-push ]
  18     [ [ reg>> ] [ vreg>> ] bi pending-interval-assoc get set-at ]
  19     bi ;
  20
  21 : remove-pending ( live-interval -- )
  22     vreg>> pending-interval-assoc get delete-at ;
  23
  24 : vreg>reg ( vreg -- reg/spill-slot )
  25     dup leader dup pending-interval-assoc get at
  26     [ 2nip ] [ swap rep-of lookup-spill-slot ] if* ;
  27
  28 ERROR: not-spilled-error vreg ;
  29
  30 : vreg>spill-slot ( vreg -- spill-slot )
  31     dup vreg>reg dup spill-slot?
  32     [ nip ]
  33     [ drop leader throw-not-spilled-error ] if ;
  34
  35 : vregs>regs ( vregs -- assoc )
  36     [ dup vreg>reg ] H{ } map>assoc ;
  37
  38 SYMBOL: unhandled-intervals
  39
  40 SYMBOL: machine-live-ins
  41
  42 : machine-live-in ( bb -- assoc )
  43     machine-live-ins get at ;
  44
  45 : compute-live-in ( bb -- )
  46     [ live-in keys vregs>regs ] keep machine-live-ins get set-at ;
  47
  48 SYMBOL: machine-edge-live-ins
  49
  50 : machine-edge-live-in ( predecessor bb -- assoc )
  51     machine-edge-live-ins get at at ;
  52
  53 : compute-edge-live-in ( bb -- )
  54     [ edge-live-ins get at [ keys vregs>regs ] assoc-map ] keep
  55     machine-edge-live-ins get set-at ;
  56
  57 SYMBOL: machine-live-outs
  58
  59 : machine-live-out ( bb -- assoc )
  60     machine-live-outs get at ;
  61
  62 : compute-live-out ( bb -- )
  63     [ live-out keys vregs>regs ] keep machine-live-outs get set-at ;
  64
  65 : heap-pop-while ( heap quot: ( key -- ? ) -- values )
  66     '[ dup heap-empty? [ f f ] [ dup heap-peek @ ] if ]
  67     [ over heap-pop* ] produce 2nip ; inline
  68
  69 : insert-spill ( live-interval -- )
  70     [ reg>> ] [ spill-rep>> ] [ spill-to>> ] tri ##spill, ;
  71
  72 : handle-spill ( live-interval -- )
  73     dup spill-to>> [ insert-spill ] [ drop ] if ;
  74
  75 : expire-interval ( live-interval -- )
  76     [ remove-pending ] [ handle-spill ] bi ;
  77
  78 : expire-old-intervals ( n -- )
  79     pending-interval-heap get swap '[ _ < ] heap-pop-while
  80     [ expire-interval ] each ;
  81
  82 : insert-reload ( live-interval -- )
  83     [ reg>> ] [ reload-rep>> ] [ reload-from>> ] tri ##reload, ;
  84
  85 : handle-reload ( live-interval -- )
  86     dup reload-from>> [ insert-reload ] [ drop ] if ;
  87
  88 : activate-interval ( live-interval -- )
  89     [ add-pending ] [ handle-reload ] bi ;
  90
  91 : activate-new-intervals ( n -- )
  92     unhandled-intervals get swap '[ _ = ] heap-pop-while
  93     [ activate-interval ] each ;
  94
  95 : prepare-insn ( n -- )
  96     [ expire-old-intervals ] [ activate-new-intervals ] bi ;
  97
  98 GENERIC: assign-registers-in-insn ( insn -- )
  99
 100 RENAMING: assign [ vreg>reg ] [ vreg>reg ] [ vreg>reg ]
 101
 102 M: vreg-insn assign-registers-in-insn
 103     [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ;
 104
 105 : assign-gc-roots ( gc-map -- )
 106     [ [ vreg>spill-slot ] map ] change-gc-roots drop ;
 107
 108 : assign-derived-roots ( gc-map -- )
 109     [ [ [ vreg>spill-slot ] bi@ ] assoc-map ] change-derived-roots drop ;
 110
 111 M: gc-map-insn assign-registers-in-insn
 112     [ [ assign-insn-defs ] [ assign-insn-uses ] [ assign-insn-temps ] tri ]
 113     [ gc-map>> [ assign-gc-roots ] [ assign-derived-roots ] bi ]
 114     bi ;
 115
 116 M: insn assign-registers-in-insn drop ;
 117
 118 : begin-block ( bb -- )
 119     {
 120         [ basic-block set ]
 121         [ block-from activate-new-intervals ]
 122         [ compute-edge-live-in ]
 123         [ compute-live-in ]
 124     } cleave ;
 125
 126 : assign-registers-in-block ( bb -- )
 127     dup begin-block
 128     [
 129         [
 130             [
 131                 {
 132                     [ insn#>> 1 - prepare-insn ]
 133                     [ insn#>> prepare-insn ]
 134                     [ assign-registers-in-insn ]
 135                     [ , ]
 136                 } cleave
 137             ] each
 138         ] V{ } make
 139     ] change-instructions compute-live-out ;
 140
 141 : init-assignment ( live-intervals -- )
 142     [ [ start>> ] map ] keep zip >min-heap unhandled-intervals set
 143     <min-heap> pending-interval-heap set
 144     H{ } clone pending-interval-assoc set
 145     H{ } clone machine-live-ins set
 146     H{ } clone machine-edge-live-ins set
 147     H{ } clone machine-live-outs set ;
 148
 149 : assign-registers ( cfg live-intervals -- )
 150     init-assignment
 151     linearization-order [ kill-block?>> ] reject
 152     [ assign-registers-in-block ] each ;