factor: trim using lists

[factor.git] / extra / compiler / cfg / gvn / gvn.factor

diff --git a/extra/compiler/cfg/gvn/gvn.factor b/extra/compiler/cfg/gvn/gvn.factor
index 6a35dca71a695d1065bd6f5e8e37d3235824c4b0..a1c77878a9a762a6aa7bb9251a884abbfc48d32c 100644 (file)
--- a/extra/compiler/cfg/gvn/gvn.factor
+++ b/extra/compiler/cfg/gvn/gvn.factor
@@ -1,91 +1,114 @@
-! 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' )
-    insn dst>> :> vn
-    vn vn set-vn
-    vn expr exprs>vns get set-at
-    insn vn vns>insns get set-at
-    insn ;
+! ! ! Global value numbering
 
-: check-redundancy ( insn -- insn' )
-    dup >expr dup exprs>vns get at
-    [ redundant-instruction ] [ useful-instruction ] ?if ;
+GENERIC: value-number ( insn -- )
+
+M: array value-number [ value-number ] each ;
 
-M: insn process-instruction
-    dup rewrite [ process-instruction ] [ ] ?if ;
+: record-defs ( insn -- ) defs-vregs [ dup set-vn ] each ;
 
-M: foldable-insn process-instruction
-    dup rewrite
-    [ process-instruction ]
-    [ dup defs-vregs length 1 = [ check-redundancy ] when ] ?if ;
+M: alien-call-insn value-number record-defs ;
+M: ##callback-inputs value-number record-defs ;
 
-M: ##copy process-instruction
-    dup [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
+M: ##copy value-number [ src>> vreg>vn ] [ dst>> ] bi set-vn ;
 
-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 ;
+: redundant-instruction ( insn vn -- )
+    swap dst>> set-vn ;
 
-M: ##phi process-instruction
-    dup rewrite
-    [ process-instruction ] [ check-redundancy ] ?if ;
+:: 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 ;
 
-M: ##phi >expr
-    inputs>> values [ vreg>vn ] map \ ##phi prefix ;
+: check-redundancy ( insn -- )
+    dup >expr dup exprs>vns get at
+    [ redundant-instruction ] [ useful-instruction ] ?if ;
 
-M: array process-instruction
-    [ process-instruction ] map ;
+M: ##phi value-number
+    dup inputs>> values [ vreg>vn ] map sift
+    dup all-equal? [
+        [ drop ] [ first redundant-instruction ] if-empty
+    ] [ drop check-redundancy ] if ;
 
-: value-numbering-step ( insns -- insns' )
-    init-value-graph
-    ! [ process-instruction ] map flatten ;
+M: insn value-number
+    dup defs-vregs length 1 = [ check-redundancy ] [ drop ] if ;
 
-    ! 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 ;
+: value-numbering-step ( insns -- )
+    [ simplify value-number ] each ;
 
 : value-numbering-iteration ( cfg -- )
-    [ value-numbering-step ] simple-optimization ;
+    clear-exprs [ value-numbering-step ] simple-analysis ;
 
-: value-numbering ( cfg -- cfg )
-    dup
-    init-gvn
+: determine-value-numbers ( cfg -- )
+    final-iteration? off
+    init-value-graph
     '[
         changed? off
         _ value-numbering-iteration
         changed? get
-    ] loop
+    ] loop ;
+
+! ! ! Global common subexpression elimination
+
+GENERIC: gcse ( insn -- insn' )
+
+M: array gcse [ gcse ] map ;
+
+: defs-available ( insn -- insn )
+    dup defs-vregs [ make-available ] each ;
+
+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 ;
 
-    dup [ init-value-graph [ process-instruction ] map flatten ] simple-optimization
-    cfg-changed predecessors-changed ;
+: value-numbering ( cfg -- )
+    {
+        needs-predecessors
+        determine-value-numbers
+        eliminate-common-subexpressions
+        cfg-changed
+        predecessors-changed
+    } apply-passes ;