extra/compiler/cfg/gvn/gvn.factor

   1 ! Copyright (C) 2008, 2010 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces arrays assocs kernel accessors fry grouping
   4 sorting sets sequences locals
   5 cpu.architecture
   6 sequences.deep
   7 compiler.cfg
   8 compiler.cfg.rpo
   9 compiler.cfg.def-use
  10 compiler.cfg.utilities
  11 compiler.cfg.instructions
  12 compiler.cfg.gvn.alien
  13 compiler.cfg.gvn.comparisons
  14 compiler.cfg.gvn.graph
  15 compiler.cfg.gvn.math
  16 compiler.cfg.gvn.rewrite
  17 compiler.cfg.gvn.slots
  18 compiler.cfg.gvn.misc
  19 compiler.cfg.gvn.expressions ;
  20 IN: compiler.cfg.gvn
  21
  22 GENERIC: process-instruction ( insn -- insn' )
  23
  24 : redundant-instruction ( insn vn -- insn' )
  25     [ dst>> ] dip [ swap set-vn ] [ <copy> ] 2bi ;
  26
  27 :: useful-instruction ( insn expr -- insn' )
  28     insn dst>> :> vn
  29     vn vn set-vn
  30     vn expr exprs>vns get set-at
  31     insn vn vns>insns get set-at
  32     insn ;
  33
  34 : check-redundancy ( insn -- insn' )
  35     dup >expr dup exprs>vns get at
  36     [ redundant-instruction ] [ useful-instruction ] ?if ;
  37
  38 M: insn process-instruction
  39     dup rewrite [ process-instruction ] [ ] ?if ;
  40
  41 M: foldable-insn process-instruction
  42     dup rewrite
  43     [ process-instruction ]
  44     [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
  45
  46 M: ##copy process-instruction
  47     dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
  48
  49 M: ##phi rewrite
  50     [ dst>> ] [ inputs>> values [ vreg>vn ] map ] bi
  51     dup sift
  52     dup all-equal?  [
  53         nip
  54         [ drop f ]
  55         [ first <copy> ] if-empty
  56     ] [ 3drop f ] if ;
  57
  58 M: ##phi process-instruction
  59     dup rewrite
  60     [ process-instruction ] [ check-redundancy ] ?if ;
  61
  62 M: ##phi >expr
  63     inputs>> values [ vreg>vn ] map \ ##phi prefix ;
  64
  65 M: array process-instruction
  66     [ process-instruction ] map ;
  67
  68 : value-numbering-step ( insns -- insns' )
  69     init-value-graph
  70     ! [ process-instruction ] map flatten ;
  71
  72     ! idea: let rewrite do the constant/copy propagation (as
  73     ! that eventually leads to better VNs), but don't actually
  74     ! use them here, since changing the CFG mid-optimistic-GVN
  75     ! won't be sound
  76     dup [ process-instruction drop ] each ;
  77
  78 : value-numbering ( cfg -- cfg )
  79     dup
  80     init-gvn
  81     '[
  82         changed? off
  83         _ [ value-numbering-step ] simple-optimization
  84         changed? get
  85     ] loop
  86
  87     dup [ init-value-graph [ process-instruction ] map flatten ] simple-optimization
  88     cfg-changed predecessors-changed ;
  89
  90 USING: io math math.private prettyprint tools.annotations
  91 compiler.cfg.debugger
  92 compiler.cfg.graphviz
  93 compiler.cfg.tco
  94 compiler.cfg.useless-conditionals
  95 compiler.cfg.branch-splitting
  96 compiler.cfg.block-joining
  97 compiler.cfg.height
  98 compiler.cfg.ssa.construction
  99 compiler.cfg.alias-analysis
 100 compiler.cfg.copy-prop
 101 compiler.cfg.dce
 102 compiler.cfg.finalization ;
 103
 104 SYMBOL: gvn-test
 105
 106 [ 0 100 [ 1 fixnum+fast ] times ]
 107 test-builder first [
 108     optimize-tail-calls
 109     delete-useless-conditionals
 110     split-branches
 111     join-blocks
 112     normalize-height
 113     construct-ssa
 114     alias-analysis
 115 ] with-cfg gvn-test set-global
 116
 117 : watch-gvn ( -- )
 118     \ value-numbering-step
 119     [
 120         '[
 121             _ call
 122             "Basic block #" write basic-block get number>> .
 123             "vregs>gvns: "  write vregs>gvns  get .
 124             "vregs>vns: "   write vregs>vns   get .
 125             "exprs>vns: "   write exprs>vns   get .
 126             "vns>insns: "   write vns>insns   get .
 127             "\n---\n" print
 128         ]
 129     ] annotate ;
 130
 131 : reset-gvn ( -- )
 132     \ value-numbering-step reset ;
 133
 134 : test-gvn ( -- )
 135     watch-gvn
 136     gvn-test get-global [
 137         dup "Before GVN" "1" (cfgviz)
 138         value-numbering
 139         dup "After GVN" "2" (cfgviz)
 140         copy-propagation
 141         dup "After CP" "3" (cfgviz)
 142         eliminate-dead-code
 143         dup "After DCE" "4" (cfgviz)
 144         finalize-cfg
 145         dup "Final CFG" "5" (cfgviz)
 146         drop
 147     ] with-cfg
 148     reset-gvn ;
 149