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