compiler.cfg.*: changed stack effect of needs-predecessors from ( cfg -- cfg') to ( cfg -- )

2014-12-10 18:24:12 +01:00 · 2014-12-10 18:24:12 +01:00 · e5866dfa80
parent 76cb665a8d
commit e5866dfa80
19 changed files with 84 additions and 80 deletions
--- a/basis/compiler/cfg/block-joining/block-joining.factor
+++ b/basis/compiler/cfg/block-joining/block-joining.factor
@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators.short-circuit kernel sequences math
-compiler.utilities compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
-compiler.cfg.predecessors compiler.cfg.utilities ;
+USING: accessors combinators combinators.short-circuit compiler.utilities
+compiler.cfg compiler.cfg.instructions compiler.cfg.rpo
+compiler.cfg.predecessors compiler.cfg.utilities kernel math sequences ;
 IN: compiler.cfg.block-joining

 ! Joining blocks that are not calls and are connected by a single CFG edge.
@ -27,10 +27,14 @@ IN: compiler.cfg.block-joining
    [ join-instructions ] [ update-successors ] 2bi ;

 : join-blocks ( cfg -- )
-    needs-predecessors
-    [
-        post-order [
-            dup join-block?
-            [ dup predecessor join-block ] [ drop ] if
-        ] each
-    ] [ cfg-changed ] [ predecessors-changed ] tri ;
+    {
+        [ needs-predecessors ]
+        [
+            post-order [
+                dup join-block?
+                [ dup predecessor join-block ] [ drop ] if
+            ] each
+        ]
+        [ cfg-changed ]
+        [ predecessors-changed ]
+    } cleave ;
--- a/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting-tests.factor
@ -9,13 +9,11 @@ IN: compiler.cfg.branch-splitting.tests

 : check-predecessors ( cfg -- )
    [ get-predecessors ]
-    [ needs-predecessors drop ]
+    [ needs-predecessors ]
    [ get-predecessors ] tri assert= ;

 : check-branch-splitting ( cfg -- )
-    needs-predecessors
-    split-branches
-    check-predecessors ;
+    [ needs-predecessors ] [ split-branches ] [ check-predecessors ] tri ;

 : test-branch-splitting ( -- )
    0 get block>cfg check-branch-splitting ;
--- a/basis/compiler/cfg/branch-splitting/branch-splitting.factor
+++ b/basis/compiler/cfg/branch-splitting/branch-splitting.factor
@ -94,14 +94,16 @@ SYMBOL: visited
    entry>> add-to-worklist ;

 : split-branches ( cfg -- )
-    needs-predecessors
-    dup init-worklist
-    ! For back-edge?
-    dup post-order drop
-
-    worklist get [
-        dup split-branch? [ dup split-branch ] when
-        successors>> [ add-to-worklist ] each
-    ] slurp-deque
-
-    cfg-changed ;
+    {
+        [ needs-predecessors ]
+        [ init-worklist ]
+        [
+            ! For back-edge?
+            post-order drop
+            worklist get [
+                dup split-branch? [ dup split-branch ] when
+                successors>> [ add-to-worklist ] each
+            ] slurp-deque
+        ]
+        [ cfg-changed ]
+    } cleave ;
--- a/basis/compiler/cfg/copy-prop/copy-prop.factor
+++ b/basis/compiler/cfg/copy-prop/copy-prop.factor
@ -120,7 +120,9 @@ PRIVATE>
 USE: compiler.cfg

 : copy-propagation ( cfg -- )
-    needs-predecessors
-    dup collect-copies
-    dup rename-copies
-    predecessors-changed ;
+    {
+        [ needs-predecessors ]
+        [ collect-copies ]
+        [ rename-copies ]
+        [ predecessors-changed ]
+    } cleave ;
--- a/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
+++ b/basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor
@ -47,7 +47,7 @@ MIXIN: dataflow-analysis
    ] when ; inline

 :: run-dataflow-analysis ( cfg dfa -- in-sets out-sets )
-    cfg needs-predecessors drop
+    cfg needs-predecessors
    H{ } clone :> in-sets
    H{ } clone :> out-sets
    cfg dfa <dfa-worklist> :> work-list
--- a/basis/compiler/cfg/dce/dce.factor
+++ b/basis/compiler/cfg/dce/dce.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2010 Slava Pestov, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs kernel namespaces sequences
+USING: accessors arrays assocs kernel namespaces sequences combinators
 compiler.cfg.instructions compiler.cfg.def-use
 compiler.cfg.rpo compiler.cfg.predecessors hash-sets sets ;
 FROM: assocs => change-at ;
@ -116,13 +116,13 @@ M: flushable-insn live-insn? defs-vregs [ live-vreg? ] any? ;
 M: insn live-insn? drop t ;

 : eliminate-dead-code ( cfg -- )
+    init-dead-code
    ! Even though we don't use predecessors directly, we depend
    ! on the predecessors pass updating phi nodes to remove dead
    ! inputs.
-    needs-predecessors
-
-    init-dead-code
-    [ [ [ build-liveness-graph ] each ] simple-analysis ]
-    [ [ [ compute-live-vregs ] each ] simple-analysis ]
-    [ [ [ live-insn? ] filter! ] simple-optimization ]
-    tri ;
+    {
+        [ needs-predecessors ]
+        [ [ [ build-liveness-graph ] each ] simple-analysis ]
+        [ [ [ compute-live-vregs ] each ] simple-analysis ]
+        [ [ [ live-insn? ] filter! ] simple-optimization ]
+    } cleave ;
--- a/basis/compiler/cfg/dominance/dominance.factor
+++ b/basis/compiler/cfg/dominance/dominance.factor
@ -79,7 +79,7 @@ PRIVATE>
 PRIVATE>

 : needs-dominance ( cfg -- )
-    needs-predecessors
+    dup needs-predecessors
    dup dominance-valid?>> [ compute-dominance t >>dominance-valid? ] unless
    drop ;

--- a/basis/compiler/cfg/gc-checks/gc-checks.factor
+++ b/basis/compiler/cfg/gc-checks/gc-checks.factor
@ -129,7 +129,7 @@ PRIVATE>

 : insert-gc-checks ( cfg -- cfg' )
    dup blocks-with-gc [
-        [ needs-predecessors ] dip
+        [ dup needs-predecessors ] dip
        [ process-block ] each
        dup cfg-changed
    ] unless-empty ;
--- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor
+++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor
@ -107,6 +107,6 @@ SYMBOL: temp-locations
    ] if ;

 : resolve-data-flow ( cfg -- )
-    needs-predecessors
    init-resolve
-    [ resolve-block-data-flow ] each-basic-block ;
+    [ needs-predecessors ]
+    [ [ resolve-block-data-flow ] each-basic-block ] bi ;
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@ -75,7 +75,7 @@ SYMBOLS: work-list loop-heads visited ;
 PRIVATE>

 : linearization-order ( cfg -- bbs )
-    needs-post-order needs-loops needs-predecessors
+    needs-post-order needs-loops dup needs-predecessors

    dup linear-order>> [ ] [
        dup (linearization-order)
--- a/basis/compiler/cfg/liveness/liveness.factor
+++ b/basis/compiler/cfg/liveness/liveness.factor
@ -158,15 +158,15 @@ SYMBOL: work-list
    ] [ drop ] if ;

 : compute-live-sets ( cfg -- )
-    needs-predecessors
-    dup compute-insns
-
    <hashed-dlist> work-list set
    H{ } clone live-ins set
    H{ } clone edge-live-ins set
    H{ } clone live-outs set
    H{ } clone base-pointers set
-    post-order add-to-work-list
+
+    [ needs-predecessors ]
+    [ compute-insns ]
+    [ post-order add-to-work-list ] tri
    work-list get [ liveness-step ] slurp-deque ;

 : live-in? ( vreg bb -- ? ) live-in key? ;
--- a/basis/compiler/cfg/loop-detection/loop-detection.factor
+++ b/basis/compiler/cfg/loop-detection/loop-detection.factor
@ -63,12 +63,13 @@ SYMBOL: loop-nesting
    ] keep loop-nesting set ;

 : detect-loops ( cfg -- cfg' )
-    needs-predecessors
    H{ } clone loops set
    HS{ } clone visited set
    HS{ } clone active set
    H{ } clone loop-nesting set
-    dup entry>> find-loop-headers process-loop-headers compute-loop-nesting ;
+    [ needs-predecessors ]
+    [ entry>> find-loop-headers process-loop-headers compute-loop-nesting ]
+    [ ] tri ;

 PRIVATE>

@ -77,5 +78,5 @@ PRIVATE>
 : current-loop-nesting ( -- n ) basic-block get loop-nesting-at ;

 : needs-loops ( cfg -- cfg' )
-    needs-predecessors
+    dup needs-predecessors
    dup loops-valid?>> [ detect-loops t >>loops-valid? ] unless ;
--- a/basis/compiler/cfg/predecessors/predecessors-docs.factor
+++ b/basis/compiler/cfg/predecessors/predecessors-docs.factor
@ -2,5 +2,5 @@ USING: compiler.cfg help.markup help.syntax kernel ;
 IN: compiler.cfg.predecessors

 HELP: needs-predecessors
-{ $values { "cfg" cfg } { "cfg'" cfg } }
+{ $values { "cfg" cfg } }
 { $description "Computes predecessor info for the cfg unless it already is up-to-date." } ;
--- a/basis/compiler/cfg/predecessors/predecessors.factor
+++ b/basis/compiler/cfg/predecessors/predecessors.factor
@ -1,6 +1,6 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors combinators fry sequences assocs compiler.cfg.rpo
+USING: kernel accessors fry sequences assocs compiler.cfg.rpo
 compiler.cfg.instructions compiler.cfg.utilities ;
 IN: compiler.cfg.predecessors

@ -18,16 +18,13 @@ IN: compiler.cfg.predecessors
 : update-phis ( bb -- )
    dup [ update-phi ] with each-phi ;

-: compute-predecessors ( cfg -- cfg' )
-    {
-        [ [ V{ } clone >>predecessors drop ] each-basic-block ]
-        [ [ update-predecessors ] each-basic-block ]
-        [ [ update-phis ] each-basic-block ]
-        [ ]
-    } cleave ;
+: compute-predecessors ( cfg -- )
+    [ [ V{ } clone >>predecessors drop ] each-basic-block ]
+    [ [ update-predecessors ] each-basic-block ]
+    [ [ update-phis ] each-basic-block ] tri ;

 PRIVATE>

-: needs-predecessors ( cfg -- cfg' )
-    dup predecessors-valid?>>
-    [ compute-predecessors t >>predecessors-valid? ] unless ;
+: needs-predecessors ( cfg -- )
+    dup predecessors-valid?>> [ drop ]
+    [ t >>predecessors-valid? compute-predecessors ] if ;
--- a/basis/compiler/cfg/representations/representations.factor
+++ b/basis/compiler/cfg/representations/representations.factor
@ -18,9 +18,8 @@ IN: compiler.cfg.representations

 : select-representations ( cfg -- cfg' )
    needs-loops
-    needs-predecessors
-
    {
+        [ needs-predecessors ]
        [ compute-components ]
        [ compute-possibilities ]
        [ compute-representations ]
--- a/basis/compiler/cfg/ssa/cssa/cssa.factor
+++ b/basis/compiler/cfg/ssa/cssa/cssa.factor
@ -70,8 +70,6 @@ SYMBOLS: edge-copies phi-copies ;
    tri ;

 : construct-cssa ( cfg -- )
-    needs-predecessors
-
-    dup [ convert-phis ] each-basic-block
-
-    cfg-changed ;
+    [ needs-predecessors ]
+    [ [ convert-phis ] each-basic-block ]
+    [ cfg-changed ] tri ;
--- a/basis/compiler/cfg/stacks/finalize/finalize.factor
+++ b/basis/compiler/cfg/stacks/finalize/finalize.factor
@ -52,8 +52,7 @@ ERROR: bad-peek dst loc ;
    [ predecessors>> ] keep '[ _ visit-edge ] each ;

 : finalize-stack-shuffling ( cfg -- cfg' )
-    needs-predecessors
-
-    dup [ visit-block ] each-basic-block
-
-    dup cfg-changed ;
+    dup
+    [ needs-predecessors ]
+    [ [ visit-block ] each-basic-block ]
+    [ cfg-changed ] tri ;
--- a/extra/compiler/cfg/gvn/gvn.factor
+++ b/extra/compiler/cfg/gvn/gvn.factor
@ -4,6 +4,7 @@ USING: namespaces arrays assocs hashtables kernel accessors fry
 grouping sorting sets sequences locals
 cpu.architecture
 sequences.deep
+combinators
 compiler.cfg
 compiler.cfg.rpo
 compiler.cfg.def-use
@ -118,7 +119,10 @@ M: insn gcse
    [ gcse-step ] simple-optimization ;

 : value-numbering ( cfg -- cfg )
-    needs-predecessors
-    dup determine-value-numbers
-    dup eliminate-common-subexpressions
-    [ cfg-changed ] [ predecessors-changed ] bi ;
+    dup {
+        [ needs-predecessors ]
+        [ determine-value-numbers ]
+        [ eliminate-common-subexpressions ]
+        [ cfg-changed ]
+        [ predecessors-changed ]
+    } cleave ;
--- a/extra/compiler/graphviz/graphviz.factor
+++ b/extra/compiler/graphviz/graphviz.factor
@ -90,7 +90,7 @@ IN: compiler.graphviz
 : dom-trees ( cfgs -- )
    [
        [
-            needs-dominance drop
+            needs-dominance
            dom-childrens get [
                [
                    bb-edge,
@ -125,7 +125,7 @@ SYMBOL: vertex-names
        {
            [ { } call-graph-edge, ]
            [ [ vertex-name ] [ label>> loop?>> { "shape=box" } { } ? ] bi node-style, ]
-            [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ] 
+            [ [ vertex-name ] [ calls>> ] bi (call-graph-back-edges) ]
            [ [ vertex-name ] [ children>> ] bi (call-graph-edges) ]
        } cleave
    ] with each ;