basis/compiler/cfg/representations/selection/selection.factor

   1 ! Copyright (C) 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors arrays assocs byte-arrays combinators
   4 compiler.cfg compiler.cfg.instructions
   5 compiler.cfg.loop-detection compiler.cfg.registers
   6 compiler.cfg.representations.coalescing
   7 compiler.cfg.representations.preferred compiler.cfg.rpo
   8 compiler.cfg.utilities compiler.utilities cpu.architecture
   9 disjoint-sets fry kernel locals math math.functions namespaces
  10 sequences sets ;
  11 IN: compiler.cfg.representations.selection
  12
  13 SYMBOL: tagged-vregs
  14
  15 SYMBOL: vreg-reps
  16
  17 : handle-def ( vreg rep -- )
  18     swap vreg>scc vreg-reps get
  19     [ [ intersect ] when* ] change-at ;
  20
  21 : handle-use ( vreg rep -- )
  22     int-rep eq? [ drop ] [ vreg>scc tagged-vregs get adjoin ] if ;
  23
  24 GENERIC: (collect-vreg-reps) ( insn -- )
  25
  26 M: ##load-reference (collect-vreg-reps)
  27     [ dst>> ] [ obj>> ] bi {
  28         { [ dup float? ] [ drop { float-rep double-rep } ] }
  29         { [ dup byte-array? ] [ drop vector-reps ] }
  30         [ drop { } ]
  31     } cond handle-def ;
  32
  33 M: vreg-insn (collect-vreg-reps)
  34     [ [ handle-use ] each-use-rep ]
  35     [ [ 1array handle-def ] each-def-rep ]
  36     [ [ 1array handle-def ] each-temp-rep ]
  37     tri ;
  38
  39 M: insn (collect-vreg-reps) drop ;
  40
  41 : collect-vreg-reps ( cfg -- )
  42     H{ } clone vreg-reps set
  43     HS{ } clone tagged-vregs set
  44     [ [ (collect-vreg-reps) ] each-non-phi ] each-basic-block ;
  45
  46 SYMBOL: possibilities
  47
  48 : possible-reps ( vreg reps -- vreg reps )
  49     { tagged-rep } union
  50     2dup [ tagged-vregs get in? not ] [ { tagged-rep } = ] bi* and
  51     [ drop { tagged-rep int-rep } ] when ;
  52
  53 : compute-possibilities ( cfg -- )
  54     collect-vreg-reps
  55     vreg-reps get [ possible-reps ] assoc-map possibilities set ;
  56
  57 ! For every vreg, compute the cost of keeping it in every possible
  58 ! representation.
  59
  60 SYMBOL: costs
  61
  62 : init-costs ( -- )
  63     possibilities get [ [ 0 ] H{ } map>assoc ] assoc-map costs set ;
  64
  65 : increase-cost ( rep scc factor -- )
  66     [ costs get at 2dup key? ] dip
  67     '[ [ current-loop-nesting 10^ _ * + ] change-at ] [ 2drop ] if ;
  68
  69 :: increase-costs ( vreg preferred factor -- )
  70     vreg vreg>scc :> scc
  71     scc possibilities get at [
  72         dup preferred eq? [ drop ] [ scc factor increase-cost ] if
  73     ] each ; inline
  74
  75 UNION: inert-tag-untag-insn
  76     ##add
  77     ##sub
  78     ##and
  79     ##or
  80     ##xor
  81     ##min
  82     ##max ;
  83
  84 UNION: inert-arithmetic-tag-untag-insn
  85     ##add-imm
  86     ##sub-imm ;
  87
  88 UNION: inert-bitwise-tag-untag-insn
  89     ##and-imm
  90     ##or-imm
  91     ##xor-imm ;
  92
  93 UNION: peephole-optimizable
  94     ##load-integer
  95     ##load-reference
  96     ##neg
  97     ##not
  98     inert-tag-untag-insn
  99     inert-arithmetic-tag-untag-insn
 100     inert-bitwise-tag-untag-insn
 101     ##mul-imm
 102     ##shl-imm
 103     ##shr-imm
 104     ##sar-imm
 105     ##compare-integer-imm
 106     ##compare-integer
 107     ##compare-integer-imm-branch
 108     ##compare-integer-branch
 109     ##test-imm
 110     ##test
 111     ##test-imm-branch
 112     ##test-branch ;
 113
 114 GENERIC: compute-insn-costs ( insn -- )
 115
 116 M: insn compute-insn-costs drop ;
 117
 118 M: vreg-insn compute-insn-costs
 119     dup peephole-optimizable? 2 5 ? '[ _ increase-costs ] each-rep ;
 120
 121 : compute-costs ( cfg -- )
 122     init-costs
 123     [
 124         [ basic-block set ]
 125         [ [ compute-insn-costs ] each-non-phi ] bi
 126     ] each-basic-block ;
 127
 128 : minimize-costs ( costs -- representations )
 129     [ nip assoc-empty? ] assoc-reject
 130     [ >alist alist-min first ] assoc-map ;
 131
 132 : compute-representations ( cfg -- )
 133     compute-costs costs get minimize-costs
 134     [ components get [ disjoint-set-members ] keep ] dip
 135     '[ dup _ representative _ at ] H{ } map>assoc
 136     representations set ;