From a5e5510615956584df083f0321df0d2bf4b49e8e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 26 Jul 2009 21:11:26 -0500
Subject: [PATCH] compiler.cfg.coalescing: work in progress

---
 .../compiler/cfg/coalescing/coalescing.factor |  42 +++++
 .../cfg/coalescing/copies/copies.factor       |   8 +
 .../cfg/coalescing/forest/forest-tests.factor |  87 ++++++++++
 .../cfg/coalescing/forest/forest.factor       |  39 +++++
 .../interference/interference.factor          |  56 ++++++
 .../process-blocks/process-blocks.factor      | 160 ++++++++++++++++++
 .../cfg/coalescing/state/state.factor         |  15 ++
 7 files changed, 407 insertions(+)
 create mode 100644 basis/compiler/cfg/coalescing/coalescing.factor
 create mode 100644 basis/compiler/cfg/coalescing/copies/copies.factor
 create mode 100644 basis/compiler/cfg/coalescing/forest/forest-tests.factor
 create mode 100644 basis/compiler/cfg/coalescing/forest/forest.factor
 create mode 100644 basis/compiler/cfg/coalescing/interference/interference.factor
 create mode 100644 basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor
 create mode 100644 basis/compiler/cfg/coalescing/state/state.factor

diff --git a/basis/compiler/cfg/coalescing/coalescing.factor b/basis/compiler/cfg/coalescing/coalescing.factor
new file mode 100644
index 0000000000..5a09b59749
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/coalescing.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel locals math math.order
+sequences
+compiler.cfg.rpo
+compiler.cfg.instructions
+compiler.cfg.dominance
+compiler.cfg.coalescing.state
+compiler.cfg.coalescing.forest
+compiler.cfg.coalescing.process-blocks ;
+IN: compiler.cfg.coalescing
+
+! Fast Copy Coalescing and Live-Range Identification
+! http://www.cs.ucsd.edu/classes/sp02/cse231/kenpldi.pdf
+
+! Dominance, liveness and def-use need to be computed
+
+: process-blocks ( cfg -- )
+    [ [ process-block ] if-has-phis ] each-basic-block ;
+
+: schedule-copies ( bb -- ) drop ;
+
+: break-interferences ( -- ) ;
+
+: insert-copies ( cfg -- ) drop ;
+
+: perform-renaming ( cfg -- ) drop ;
+
+: remove-phis-from-block ( bb -- )
+    instructions>> [ ##phi? not ] filter-here ;
+
+: remove-phis ( cfg -- )
+    [ [ remove-phis-from-block ] if-has-phis ] each-basic-block ;
+
+: coalesce ( cfg -- cfg' )
+    init-coalescing
+    dup compute-dfs
+    dup process-blocks
+    break-interferences
+    dup insert-copies
+    dup perform-renaming
+    dup remove-phis ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/coalescing/copies/copies.factor b/basis/compiler/cfg/coalescing/copies/copies.factor
new file mode 100644
index 0000000000..c0a3ed8923
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/copies/copies.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: compiler.cfg.coalescing.copies
+
+: schedule-copies ( bb -- ) drop ;
+
+: insert-copies ( cfg -- ) drop ;
diff --git a/basis/compiler/cfg/coalescing/forest/forest-tests.factor b/basis/compiler/cfg/coalescing/forest/forest-tests.factor
new file mode 100644
index 0000000000..3cbcbb186a
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/forest/forest-tests.factor
@@ -0,0 +1,87 @@
+USING: accessors compiler.cfg compiler.cfg.coalescing.forest
+compiler.cfg.debugger compiler.cfg.dominance compiler.cfg.instructions
+compiler.cfg.predecessors compiler.cfg.registers compiler.cfg.def-use
+cpu.architecture kernel namespaces sequences tools.test vectors sorting
+math.order ;
+IN: compiler.cfg.coalescing.forest.tests
+
+V{ T{ ##peek f V int-regs 0 D 0 } } clone 0 test-bb
+V{ T{ ##peek f V int-regs 1 D 0 } } clone 1 test-bb
+V{ T{ ##peek f V int-regs 2 D 0 } } clone 2 test-bb
+V{ T{ ##peek f V int-regs 3 D 0 } } clone 3 test-bb
+V{ T{ ##peek f V int-regs 4 D 0 } } clone 4 test-bb
+V{ T{ ##peek f V int-regs 5 D 0 } } clone 5 test-bb
+V{ T{ ##peek f V int-regs 6 D 0 } } clone 6 test-bb
+
+0 get 1 get 2 get V{ } 2sequence >>successors drop
+2 get 3 get 4 get V{ } 2sequence >>successors drop
+3 get 5 get 1vector >>successors drop
+4 get 5 get 1vector >>successors drop
+1 get 6 get 1vector >>successors drop
+5 get 6 get 1vector >>successors drop
+
+: clean-up-forest ( forest -- forest' )
+    [ [ vreg>> n>> ] compare ] sort
+    [
+        [ clean-up-forest ] change-children
+        [ number>> ] change-bb
+    ] V{ } map-as ;
+
+: test-dom-forest ( vregs -- forest )
+    cfg new 0 get >>entry
+    compute-predecessors
+    dup compute-dominance
+    dup compute-def-use
+    compute-dfs
+    compute-dom-forest
+    clean-up-forest ;
+
+[ V{ } ] [ { } test-dom-forest ] unit-test
+
+[ V{ T{ dom-forest-node f V int-regs 0 0 V{ } } } ]
+[ { V int-regs 0 } test-dom-forest ]
+unit-test
+
+[
+    V{
+        T{ dom-forest-node
+           f
+           V int-regs 0
+           0
+           V{ T{ dom-forest-node f V int-regs 1 1 V{ } } }
+        }
+    }
+]
+[ { V int-regs 0 V int-regs 1 } test-dom-forest ]
+unit-test
+
+[
+    V{
+        T{ dom-forest-node
+           f
+           V int-regs 1
+           1
+           V{ }
+        }
+        T{ dom-forest-node
+           f
+           V int-regs 2
+           2
+           V{
+               T{ dom-forest-node f V int-regs 3 3 V{ } }
+               T{ dom-forest-node f V int-regs 4 4 V{ } }
+               T{ dom-forest-node f V int-regs 5 5 V{ } }
+           }
+        }
+        T{ dom-forest-node
+           f
+           V int-regs 6
+           6
+           V{ }
+        }
+    }
+]
+[
+    { V int-regs 1 V int-regs 6 V int-regs 2 V int-regs 3 V int-regs 4 V int-regs 5 }
+    test-dom-forest
+] unit-test
\ No newline at end of file
diff --git a/basis/compiler/cfg/coalescing/forest/forest.factor b/basis/compiler/cfg/coalescing/forest/forest.factor
new file mode 100644
index 0000000000..f1f8334975
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/forest/forest.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel math math.order
+namespaces sequences sorting vectors compiler.cfg.def-use
+compiler.cfg.dominance ;
+IN: compiler.cfg.coalescing.forest
+
+TUPLE: dom-forest-node vreg bb children ;
+
+<PRIVATE
+
+: sort-vregs-by-bb ( vregs -- alist )
+    defs-1 get
+    '[ dup _ at ] { } map>assoc
+    [ [ second pre-of ] compare ] sort ;
+
+: <dom-forest-node> ( vreg bb parent -- node )
+    [ V{ } clone dom-forest-node boa dup ] dip children>> push ;
+
+: <virtual-root> ( -- node )
+    f f V{ } clone dom-forest-node boa ;
+
+: find-parent ( pre stack -- parent )
+    2dup last vreg>> def-of maxpre-of > [
+        dup pop* find-parent
+    ] [ nip last ] if ;
+
+: (compute-dom-forest) ( vreg bb stack -- )
+    [ dup pre-of ] dip [ find-parent <dom-forest-node> ] keep push ;
+
+PRIVATE>
+
+: compute-dom-forest ( vregs -- forest )
+    ! compute-dfs must be called on the CFG first
+    <virtual-root> [
+        1vector
+        [ sort-vregs-by-bb ] dip
+        '[ _ (compute-dom-forest) ] assoc-each
+    ] keep children>> ;
diff --git a/basis/compiler/cfg/coalescing/interference/interference.factor b/basis/compiler/cfg/coalescing/interference/interference.factor
new file mode 100644
index 0000000000..36dea6f0a0
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/interference/interference.factor
@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators combinators.short-circuit
+kernel math namespaces sequences compiler.cfg.def-use
+compiler.cfg.liveness ;
+IN: compiler.cfg.coalescing.interference
+
+! Local interference testing. Requires live-out information
+<PRIVATE
+
+SYMBOLS: def-index kill-index ;
+
+: compute-local-live-ranges ( bb -- )
+    H{ } clone def-index set
+    H{ } clone kill-index set
+    [
+        instructions>> [
+            [ swap defs-vregs [ def-index get set-at ] with each ]
+            [ swap uses-vregs [ kill-index get set-at ] with each ]
+            2bi
+        ] each-index
+    ]
+    [ live-out keys [ [ 1/0. ] dip kill-index get set-at ] each ]
+    bi ;
+
+: kill-after-def? ( vreg1 vreg2 -- ? )
+    ! If first register is killed after second one is defined, they interfere
+    [ kill-index get at ] [ def-index get at ] bi* >= ;
+
+: interferes-same-block? ( vreg1 vreg2 -- ? )
+    ! If both are defined in the same basic block, they interfere if their
+    ! local live ranges intersect.
+    { [ kill-after-def? ] [ swap kill-after-def? ] } 2|| ;
+
+: interferes-first-dominates? ( vreg1 vreg2 -- ? )
+    ! If vreg1 dominates vreg2, then they interfere if vreg2's definition
+    ! occurs before vreg1 is killed.
+    kill-after-def? ;
+
+: interferes-second-dominates? ( vreg1 vreg2 -- ? )
+    ! If vreg2 dominates vreg1, then they interfere if vreg1's definition
+    ! occurs before vreg2 is killed.
+    swap kill-after-def? ;
+
+PRIVATE>
+
+SYMBOLS: +same-block+ +first-dominates+ +second-dominates+ ;
+
+: interferes? ( vreg1 vreg2 bb mode -- ? )
+    ! local interference test - mode is one of the above symbols
+    [ compute-local-live-ranges ] dip
+    {
+        { +same-block+ [ interferes-same-block? ] }
+        { +first-dominates+ [ interferes-first-dominates? ] }
+        { +second-dominates+ [ interferes-second-dominates? ] }
+    } case ;
\ No newline at end of file
diff --git a/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor
new file mode 100644
index 0000000000..6e73bb5e2f
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/process-blocks/process-blocks.factor
@@ -0,0 +1,160 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel locals math math.order arrays
+namespaces sequences sorting sets combinators combinators.short-circuit
+dlists deques make
+compiler.cfg.def-use
+compiler.cfg.instructions
+compiler.cfg.liveness
+compiler.cfg.dominance
+compiler.cfg.coalescing.state
+compiler.cfg.coalescing.forest
+compiler.cfg.coalescing.interference ;
+IN: compiler.cfg.coalescing.process-blocks
+
+SYMBOLS: phi-union unioned-blocks ;
+
+:: operand-live-into-phi-node's-block? ( bb src dst -- ? )
+    src bb live-in key? ;
+
+:: phi-node-is-live-out-of-operand's-block? ( bb src dst -- ? )
+    dst src def-of live-out key? ;
+
+:: operand-is-phi-node-and-live-into-operand's-block? ( bb src dst -- ? )
+    { [ src insn-of ##phi? ] [ src src def-of live-in key? ] } 0&& ;
+
+:: operand-being-renamed? ( bb src dst -- ? )
+    src processed-names get key? ;
+
+:: two-operands-in-same-block? ( bb src dst -- ? )
+    src def-of unioned-blocks get key? ;
+
+: trivial-interference? ( bb src dst -- ? )
+    {
+        [ operand-live-into-phi-node's-block? ]
+        [ phi-node-is-live-out-of-operand's-block? ]
+        [ operand-is-phi-node-and-live-into-operand's-block? ]
+        [ operand-being-renamed? ]
+        [ two-operands-in-same-block? ]
+    } 3|| ;
+
+: don't-coalesce ( bb src dst -- )
+    2nip processed-name ;
+
+:: trivial-interference ( bb src dst -- )
+    dst src bb waiting-for push-at
+    src used-by-another get push ;
+
+:: add-to-renaming-set ( bb src dst -- )
+    src phi-union get conjoin
+    src def-of unioned-blocks get conjoin ;
+
+: process-phi-operand ( bb src dst -- )
+    {
+        { [ 2dup eq? ] [ don't-coalesce ] }
+        { [ 3dup trivial-interference? ] [ trivial-interference ] }
+        [ add-to-renaming-set ]
+    } cond ;
+
+SYMBOLS: visited work-list ;
+
+: node-is-live-in-of-child? ( node child -- ? )
+    [ vreg>> ] [ bb>> live-in ] bi* key? ;
+
+: node-is-live-out-of-child? ( node child -- ? )
+    [ vreg>> ] [ bb>> live-out ] bi* key? ;
+
+:: insert-copy ( bb src dst -- )
+    bb src dst trivial-interference
+    src phi-union get delete-at ;
+
+:: insert-copy-for-parent ( bb src node dst -- )
+    src node vreg>> eq? [ bb src dst insert-copy ] when ;
+
+: insert-copies-for-parent ( ##phi node child -- )
+    drop
+    [ [ inputs>> ] [ dst>> ] bi ] dip
+    '[ _ _ insert-copy-for-parent ] assoc-each ;
+
+: defined-in-same-block? ( node child -- ? ) [ bb>> ] bi@ eq? ;
+
+: add-interference ( ##phi node child -- )
+    [ vreg>> ] bi@ 2array , drop ;
+
+: add-to-work-list ( child -- inserted? )
+    dup visited get key? [ drop f ] [ work-list get push-back t ] if ;
+
+: process-df-child ( ##phi node child -- inserted? )
+    [
+        {
+            { [ 2dup node-is-live-out-of-child? ] [ insert-copies-for-parent ] }
+            { [ 2dup node-is-live-in-of-child? ] [ add-interference ] }
+            { [ 2dup defined-in-same-block? ] [ add-interference ] }
+            [ 3drop ]
+        } cond
+    ]
+    [ add-to-work-list ]
+    bi ;
+
+: process-df-node ( ##phi node -- )
+    dup visited get conjoin
+    dup children>> [ process-df-child ] with with map
+    [ ] any? [ work-list get pop-back* ] unless ;
+
+: process-phi-union ( ##phi dom-forest -- )
+    H{ } clone visited set
+    <dlist> [ push-all-front ] keep
+    [ work-list set ] [ [ process-df-node ] with slurp-deque ] bi ;
+
+:: add-local-interferences ( bb ##phi -- )
+    phi-union get [
+        drop dup def-of bb eq?
+        [ ##phi dst>> 2array , ] [ drop ] if
+    ] assoc-each ;
+
+: compute-local-interferences ( bb ##phi -- pairs )
+    [
+        [ phi-union get compute-dom-forest process-phi-union drop ]
+        [ add-local-interferences ]
+        2bi
+    ] { } make ;
+
+:: insert-copies-for-interference ( ##phi src -- )
+    ##phi inputs>> [| bb src' |
+        src src' eq? [ bb src ##phi dst>> insert-copy ] when
+    ] assoc-each ;
+
+:: same-block ( ##phi vreg1 vreg2 bb1 bb2 -- )
+    vreg1 vreg2 bb1 +same-block+ interferes?
+    [ ##phi vreg1 insert-copies-for-interference ] when ;
+
+:: first-dominates ( ##phi vreg1 vreg2 bb1 bb2 -- )
+    vreg1 vreg2 bb2 +first-dominates+ interferes?
+    [ ##phi vreg1 insert-copies-for-interference ] when ;
+
+:: second-dominates ( ##phi vreg1 vreg2 bb1 bb2 -- )
+    vreg1 vreg2 bb1 +second-dominates+ interferes?
+    [ ##phi vreg1 insert-copies-for-interference ] when ;
+
+: process-local-interferences ( ##phi pairs -- )
+    [
+        first2 2dup [ def-of ] bi@ {
+            { [ 2dup eq? ] [ same-block ] }
+            { [ 2dup dominates? ] [ first-dominates ] }
+            [ second-dominates ]
+        } cond
+    ] with each ;
+
+: add-renaming-set ( ##phi -- )
+    dst>> phi-union get swap renaming-sets get set-at
+    phi-union get [ drop processed-name ] assoc-each ;
+
+:: process-phi ( bb ##phi -- )
+    H{ } phi-union set
+    H{ } unioned-blocks set
+    ##phi inputs>> ##phi dst>> '[ _ process-phi-operand ] assoc-each
+    ##phi bb ##phi compute-local-interferences process-local-interferences
+    ##phi add-renaming-set ;
+
+: process-block ( bb -- )
+    dup [ dup ##phi? [ process-phi t ] [ 2drop f ] if ] with all? drop ;
diff --git a/basis/compiler/cfg/coalescing/state/state.factor b/basis/compiler/cfg/coalescing/state/state.factor
new file mode 100644
index 0000000000..b2c2f59e45
--- /dev/null
+++ b/basis/compiler/cfg/coalescing/state/state.factor
@@ -0,0 +1,15 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: namespaces sets kernel assocs ;
+IN: compiler.cfg.coalescing.state
+
+SYMBOLS: processed-names waiting used-by-another renaming-sets ;
+
+: init-coalescing ( -- )
+    H{ } clone processed-names set
+    H{ } clone waiting set
+    V{ } clone used-by-another set ;
+
+: processed-name ( vreg -- ) processed-names get conjoin ;
+
+: waiting-for ( bb -- assoc ) waiting get [ drop H{ } clone ] cache ;