-! Copyright (C) 2008, 2010 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov, 2011 Alex Vondrak
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces arrays assocs kernel accessors fry grouping
-sorting sets sequences locals
-cpu.architecture
-sequences.deep
-compiler.cfg
-compiler.cfg.rpo
-compiler.cfg.def-use
-compiler.cfg.utilities
-compiler.cfg.instructions
-compiler.cfg.gvn.alien
-compiler.cfg.gvn.comparisons
-compiler.cfg.gvn.graph
-compiler.cfg.gvn.math
-compiler.cfg.gvn.rewrite
-compiler.cfg.gvn.slots
-compiler.cfg.gvn.misc
-compiler.cfg.gvn.expressions ;
+USING: accessors arrays assocs compiler.cfg compiler.cfg.def-use
+compiler.cfg.gvn.avail compiler.cfg.gvn.expressions
+compiler.cfg.gvn.graph compiler.cfg.gvn.rewrite
+compiler.cfg.instructions compiler.cfg.predecessors
+compiler.cfg.rpo compiler.cfg.utilities grouping kernel
+namespaces sequences sequences.deep ;
IN: compiler.cfg.gvn
-GENERIC: process-instruction ( insn -- insn' )
+GENERIC: simplify ( insn -- insn' )
-: redundant-instruction ( insn vn -- insn' )
- [ dst>> ] dip [ swap set-vn ] [ <copy> ] 2bi ;
+M: insn simplify dup rewrite [ simplify ] [ dup >avail-insn-uses ] ?if ;
+M: array simplify [ simplify ] map ;
+M: ##copy simplify ;
-:: useful-instruction ( insn expr -- insn' )
+! ! ! Global value numbering
+
+GENERIC: value-number ( insn -- )
+
+M: array value-number [ value-number ] each ;
+
+: record-defs ( insn -- ) defs-vregs [ dup set-vn ] each ;
+
+M: alien-call-insn value-number record-defs ;
+M: ##callback-inputs value-number record-defs ;
+
+M: ##copy value-number [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
+
+: redundant-instruction ( insn vn -- )
+ swap dst>> set-vn ;
+
+:: useful-instruction ( insn expr -- )
insn dst>> :> vn
vn vn set-vn
vn expr exprs>vns get set-at
- insn vn vns>insns get set-at
- insn ;
+ insn vn vns>insns get set-at ;
-: check-redundancy ( insn -- insn' )
+: check-redundancy ( insn -- )
dup >expr dup exprs>vns get at
[ redundant-instruction ] [ useful-instruction ] ?if ;
-M: insn process-instruction
- dup rewrite [ process-instruction ] [ ] ?if ;
+M: ##phi value-number
+ dup inputs>> values [ vreg>vn ] map sift
+ dup all-equal? [
+ [ drop ] [ first redundant-instruction ] if-empty
+ ] [ drop check-redundancy ] if ;
-M: foldable-insn process-instruction
- dup rewrite
- [ process-instruction ]
- [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
+M: insn value-number
+ dup defs-vregs length 1 = [ check-redundancy ] [ drop ] if ;
-M: ##copy process-instruction
- dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
+: value-numbering-step ( insns -- )
+ [ simplify value-number ] each ;
-M: ##phi rewrite
- [ dst>> ] [ inputs>> values [ vreg>vn ] map ] bi
- dup sift
- dup all-equal? [
- nip
- [ drop f ]
- [ first <copy> ] if-empty
- ] [ 3drop f ] if ;
+: value-numbering-iteration ( cfg -- )
+ clear-exprs [ value-numbering-step ] simple-analysis ;
-M: ##phi process-instruction
- dup rewrite
- [ process-instruction ] [ check-redundancy ] ?if ;
+: determine-value-numbers ( cfg -- )
+ final-iteration? off
+ init-value-graph
+ '[
+ changed? off
+ _ value-numbering-iteration
+ changed? get
+ ] loop ;
-M: ##phi >expr
- inputs>> values [ vreg>vn ] map \ ##phi prefix ;
+! ! ! Global common subexpression elimination
-M: array process-instruction
- [ process-instruction ] map ;
+GENERIC: gcse ( insn -- insn' )
-: value-numbering-step ( insns -- insns' )
- init-value-graph
- ! [ process-instruction ] map flatten ;
+M: array gcse [ gcse ] map ;
- ! idea: let rewrite do the constant/copy propagation (as
- ! that eventually leads to better VNs), but don't actually
- ! use them here, since changing the CFG mid-optimistic-GVN
- ! won't be sound
- dup [ process-instruction drop ] each ;
+: defs-available ( insn -- insn )
+ dup defs-vregs [ make-available ] each ;
-: value-numbering ( cfg -- cfg )
- dup
- init-gvn
- '[
- changed? off
- _ [ value-numbering-step ] simple-optimization
- changed? get
- ] loop
-
- dup [ init-value-graph [ process-instruction ] map flatten ] simple-optimization
- cfg-changed predecessors-changed ;
-
-USING: io math math.private prettyprint tools.annotations
-compiler.cfg.debugger
-compiler.cfg.graphviz
-compiler.cfg.tco
-compiler.cfg.useless-conditionals
-compiler.cfg.branch-splitting
-compiler.cfg.block-joining
-compiler.cfg.height
-compiler.cfg.ssa.construction
-compiler.cfg.alias-analysis
-compiler.cfg.copy-prop
-compiler.cfg.dce
-compiler.cfg.finalization ;
-
-SYMBOL: gvn-test
-
-[ 0 100 [ 1 fixnum+fast ] times ]
-test-builder first [
- optimize-tail-calls
- delete-useless-conditionals
- split-branches
- join-blocks
- normalize-height
- construct-ssa
- alias-analysis
-] with-cfg gvn-test set-global
-
-: watch-gvn ( -- )
- \ value-numbering-step
- [
- '[
- _ call
- "Basic block #" write basic-block get number>> .
- "vregs>gvns: " write vregs>gvns get .
- "vregs>vns: " write vregs>vns get .
- "exprs>vns: " write exprs>vns get .
- "vns>insns: " write vns>insns get .
- "\n---\n" print
- ]
- ] annotate ;
-
-: reset-gvn ( -- )
- \ value-numbering-step reset ;
-
-: test-gvn ( -- )
- watch-gvn
- gvn-test get-global [
- dup "Before GVN" "1" (cfgviz)
- value-numbering
- dup "After GVN" "2" (cfgviz)
- copy-propagation
- dup "After CP" "3" (cfgviz)
- eliminate-dead-code
- dup "After DCE" "4" (cfgviz)
- finalize-cfg
- dup "Final CFG" "5" (cfgviz)
- drop
- ] with-cfg
- reset-gvn ;
+M: alien-call-insn gcse defs-available ;
+M: ##callback-inputs gcse defs-available ;
+M: ##copy gcse defs-available ;
+
+: ?eliminate ( insn vn -- insn' )
+ dup available? [
+ [ dst>> dup make-available ] dip <copy>
+ ] [ drop defs-available ] if ;
+
+: eliminate-redundancy ( insn -- insn' )
+ dup >expr exprs>vns get at >avail-vreg
+ [ ?eliminate ] [ defs-available ] if* ;
+
+M: ##phi gcse
+ dup inputs>> values [ vreg>vn ] map sift
+ dup all-equal? [
+ [ first ?eliminate ] unless-empty
+ ] [ drop eliminate-redundancy ] if ;
+
+M: insn gcse
+ dup defs-vregs length 1 = [ eliminate-redundancy ] when ;
+
+: gcse-step ( insns -- insns' )
+ [ simplify gcse ] map flatten ;
+
+: eliminate-common-subexpressions ( cfg -- )
+ final-iteration? on
+ compute-congruence-classes
+ dup compute-avail-sets
+ [ gcse-step ] simple-optimization ;
+: value-numbering ( cfg -- )
+ {
+ needs-predecessors
+ determine-value-numbers
+ eliminate-common-subexpressions
+ cfg-changed
+ predecessors-changed
+ } apply-passes ;