basis/compiler/cfg/ssa/destruction/coalescing/coalescing.factor

   1 USING: accessors arrays assocs compiler.cfg.def-use
   2 compiler.cfg.instructions compiler.cfg.linearization
   3 compiler.cfg.registers compiler.cfg.ssa.destruction.leaders
   4 compiler.cfg.ssa.interference cpu.architecture fry kernel make
   5 namespaces sequences sets sorting ;
   6 IN: compiler.cfg.ssa.destruction.coalescing
   7
   8 : zip-scalar ( scalar seq -- pairs )
   9     [ 2array ] with map ;
  10
  11 SYMBOL: class-element-map
  12
  13 : value-of ( vreg -- value )
  14     dup insn-of dup ##tagged>integer? [ nip src>> ] [ drop ] if ;
  15
  16 : coalesce-elements ( merged follower leader -- )
  17     class-element-map get [ delete-at ] [ set-at ] bi-curry bi* ;
  18
  19 : coalesce-vregs ( merged follower leader -- )
  20     2dup swap leader-map get set-at coalesce-elements ;
  21
  22 : vregs-interfere? ( vreg1 vreg2 -- merged/f ? )
  23     class-element-map get '[ _ at ] bi@ sets-interfere? ;
  24
  25 ERROR: vregs-shouldn't-interfere vreg1 vreg2 ;
  26
  27 : try-eliminate-copy ( follower leader must? -- )
  28     -rot leaders 2dup = [ 3drop ] [
  29         2dup vregs-interfere? [
  30             drop rot [ vregs-shouldn't-interfere ] [ 2drop ] if
  31         ] [ -rot coalesce-vregs drop ] if
  32     ] if ;
  33
  34 : try-eliminate-copies ( pairs must? -- )
  35     '[ first2 _ try-eliminate-copy ] each ;
  36
  37 : initial-leaders ( insns -- leaders )
  38     [ [ defs-vregs ] [ temp-vregs ] bi append ] map concat unique ;
  39
  40 : initial-class-elements ( -- class-elements )
  41     defs get [ [ dup dup value-of ] dip <vreg-info> 1array ] assoc-map ;
  42
  43 : init-coalescing ( insns -- )
  44     initial-leaders leader-map set
  45     initial-class-elements class-element-map set ;
  46
  47 GENERIC: coalesce-now ( insn -- )
  48
  49 M: insn coalesce-now drop ;
  50
  51 M: ##tagged>integer coalesce-now
  52     [ dst>> ] [ src>> ] bi t try-eliminate-copy ;
  53
  54 M: ##phi coalesce-now
  55     [ dst>> ] [ inputs>> values ] bi zip-scalar
  56     natural-sort t try-eliminate-copies ;
  57
  58 GENERIC: coalesce-later ( insn -- )
  59
  60 M: insn coalesce-later drop ;
  61
  62 M: alien-call-insn coalesce-later drop ;
  63
  64 M: vreg-insn coalesce-later
  65     [ defs-vregs ] [ uses-vregs ] bi zip ?first [ , ] when* ;
  66
  67 M: ##copy coalesce-later
  68     [ dst>> ] [ src>> ] bi 2array , ;
  69
  70 M: ##parallel-copy coalesce-later
  71     values>> % ;
  72
  73 : eliminatable-copy? ( vreg1 vreg2 -- ? )
  74     [ rep-of ] bi@ [ [ reg-class-of ] same? ] [ [ rep-size ] same? ] 2bi and ;
  75
  76 : coalesce-cfg ( cfg -- )
  77     cfg>insns-rpo dup init-coalescing
  78     [ [ [ coalesce-now ] [ coalesce-later ] bi ] each ] { } make
  79     [ first2 eliminatable-copy? ] filter f try-eliminate-copies ;