compiler.cfg.copy-prop: optimistic copy propagation

basis/compiler/cfg/copy-prop/copy-prop-tests.factor

@@ -0,0 +1,107 @@
+USING: compiler.cfg.copy-prop tools.test namespaces kernel
+compiler.cfg.debugger compiler.cfg accessors
+compiler.cfg.registers compiler.cfg.instructions
+cpu.architecture ;
+IN: compiler.cfg.copy-prop.tests
+
+: test-copy-propagation ( -- )
+    cfg new 0 get >>entry copy-propagation drop ;
+
+! Simple example
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##peek f 1 D 1 }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##copy f 2 0 any-rep }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##phi f 3 H{ { 2 0 } { 3 2 } } }
+    T{ ##phi f 4 H{ { 2 1 } { 3 2 } } }
+    T{ ##phi f 5 H{ { 2 1 } { 3 0 } } }
+    T{ ##branch }
+} 4 test-bb
+
+V{
+    T{ ##copy f 6 4 any-rep }
+    T{ ##replace f 3 D 0 }
+    T{ ##replace f 5 D 1 }
+    T{ ##replace f 6 D 2 }
+    T{ ##branch }
+} 5 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 6 test-bb
+
+0 1 edge
+1 { 2 3 } edges
+2 4 edge
+3 4 edge
+4 5 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+    V{
+        T{ ##replace f 0 D 0 }
+        T{ ##replace f 4 D 1 }
+        T{ ##replace f 4 D 2 }
+        T{ ##branch }
+    }
+] [ 5 get instructions>> ] unit-test
+
+! Test optimistic assumption
+V{
+    T{ ##prologue }
+    T{ ##branch }
+} 0 test-bb
+
+V{
+    T{ ##peek f 0 D 0 }
+    T{ ##branch }
+} 1 test-bb
+
+V{
+    T{ ##phi f 1 H{ { 1 0 } { 2 2 } } }
+    T{ ##copy f 2 1 any-rep }
+    T{ ##branch }
+} 2 test-bb
+
+V{
+    T{ ##replace f 2 D 1 }
+    T{ ##branch }
+} 3 test-bb
+
+V{
+    T{ ##epilogue }
+    T{ ##return }
+} 4 test-bb
+
+0 1 edge
+1 2 edge
+2 { 2 3 } edges
+3 4 edge
+
+[ ] [ test-copy-propagation ] unit-test
+
+[
+    V{
+        T{ ##replace f 0 D 1 }
+        T{ ##branch }
+    }
+] [ 3 get instructions>> ] unit-test

basis/compiler/cfg/copy-prop/copy-prop.factor

@@ -1,78 +1,90 @@
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel namespaces assocs accessors sequences grouping
+USING: sets kernel namespaces assocs accessors sequences grouping
-combinators compiler.cfg.rpo compiler.cfg.renaming
+combinators fry compiler.cfg.def-use compiler.cfg.rpo
-compiler.cfg.instructions compiler.cfg.predecessors ;
+compiler.cfg.renaming compiler.cfg.instructions
+compiler.cfg.predecessors ;
+FROM: namespaces => set ;
 IN: compiler.cfg.copy-prop
 
-! The first three definitions are also used in compiler.cfg.alias-analysis.
-SYMBOL: copies
-
-! Initialized per-basic-block; a mapping from inputs to dst for eliminating
-! redundant phi instructions
-SYMBOL: phis
-
-: resolve ( vreg -- vreg )
-    copies get ?at drop ;
-
-: (record-copy) ( dst src -- )
-    swap copies get set-at ; inline
-
-: record-copy ( ##copy -- )
-    [ dst>> ] [ src>> resolve ] bi (record-copy) ; inline
-
 <PRIVATE
 
+SYMBOL: changed?
+
+SYMBOL: copies
+
+! Initialized per-basic-block; a mapping from inputs to dst for
+! eliminating redundant ##phi instructions
+SYMBOL: phis
+
+: resolve ( vreg -- vreg )
+    copies get at ;
+
+: record-copy ( dst src -- )
+    swap copies get maybe-set-at [ changed? on ] when ; inline
+
 GENERIC: visit-insn ( insn -- )
 
-M: ##copy visit-insn record-copy ;
+M: ##copy visit-insn
+    [ dst>> ] [ src>> resolve ] bi
+    dup [ record-copy ] [ 2drop ] if ;
 
-: useless-phi ( dst inputs -- ) first (record-copy) ;
+: useless-phi ( dst inputs -- ) first record-copy ;
 
-: redundant-phi ( dst inputs -- ) phis get at (record-copy) ;
+: redundant-phi ( dst inputs -- ) phis get at record-copy ;
 
-: record-phi ( dst inputs -- ) phis get set-at ;
+: record-phi ( dst inputs -- )
+    [ phis get set-at ] [ drop dup record-copy ] 2bi ;
 
 M: ##phi visit-insn
     [ dst>> ] [ inputs>> values [ resolve ] map ] bi
-    {
+    dup phis get key? [ redundant-phi ] [
-        { [ dup all-equal? ] [ useless-phi ] }
+        dup sift
-        { [ dup phis get key? ] [ redundant-phi ] }
+        dup all-equal?
-        [ record-phi ]
+        [ nip useless-phi ]
-    } cond ;
+        [ drop record-phi ] if
+    ] if ;
+
+M: vreg-insn visit-insn
+    defs-vreg [ dup record-copy ] when* ;
 
 M: insn visit-insn drop ;
 
-: collect-copies ( cfg -- )
+: (collect-copies) ( cfg -- )
-    H{ } clone copies set
     [
-        H{ } clone phis set
+        phis get clear-assoc
         instructions>> [ visit-insn ] each
     ] each-basic-block ;
 
+: collect-copies ( cfg -- )
+    H{ } clone copies set
+    H{ } clone phis set
+    '[
+        changed? off
+        _ (collect-copies)
+        changed? get
+    ] loop ;
+
 GENERIC: update-insn ( insn -- keep? )
 
 M: ##copy update-insn drop f ;
 
 M: ##phi update-insn
-    dup dst>> copies get key? [ drop f ] [ call-next-method ] if ;
+    dup call-next-method drop
+    [ dst>> ] [ inputs>> values ] bi [ = not ] with any? ;
 
-M: insn update-insn rename-insn-uses t ;
+M: vreg-insn update-insn rename-insn-uses t ;
+
+M: insn update-insn drop t ;
 
 : rename-copies ( cfg -- )
-    copies get dup assoc-empty? [ 2drop ] [
+    copies get renamings set
-        renamings set
+    [ [ update-insn ] filter! ] simple-optimization ;
-        [
-            instructions>> [ update-insn ] filter! drop
-        ] each-basic-block
-    ] if ;
 
 PRIVATE>
 
 : copy-propagation ( cfg -- cfg' )
     needs-predecessors
 
-    [ collect-copies ]
+    dup collect-copies
-    [ rename-copies ]
+    dup rename-copies ;
-    [ ]
-    tri ;