Hoopl: improve postorder calculation

- Fix the naming and comments to indicate that we are calculating
  *reverse* postorder (and not the standard postorder).

- Rewrite the calculation to avoid CPS code. I found it fairly
  difficult to understand and the new one seems faster (according to
  nofib, decreases compiler allocations by 0.2%)

- Remove `LabelsPtr`, which seems unnecessary and could be *really*
  confusing. For instance, previously:
  `postorder_dfs_from <block with label X>`
  and
  `postorder_dfs_from <label X>`
  would actually mean quite different things (and give different
  results).

- Change the `Dataflow` module to always use entry of the graph for
  reverse postorder calculation. This should be the only change in
  behavior of this commit.

  Previously, if the caller provided initial facts for some of the
  labels, we would use those labels for our postorder calculation.
  However, I don't think that's correct in general - if the initial
  facts did not contain the entry of the graph, we would never analyze
  the blocks reachable from the entry but unreachable from the labels
  provided with the initial facts. It seems that the only analysis that
  used this was proc-point analysis, which I think would always include
  the entry block (so I don't think there's any bug due to this).

Signed-off-by: Michal Terepeta <michal.terepeta@gmail.com>

Test Plan: ./validate

Reviewers: bgamari, simonmar

Reviewed By: simonmar

Subscribers: rwbarton, thomie, carter

Differential Revision: https://phabricator.haskell.org/D4464

5 files changed, 83 insertions, 0 deletions

diff --git a/testsuite/tests/cmm/Makefile b/testsuite/tests/cmm/Makefile
new file mode 100644
index 0000000000..9a36a1c5fe
--- /dev/null
+++ b/testsuite/tests/cmm/Makefile
@@ -0,0 +1,3 @@
+TOP=../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/cmm/should_run/HooplPostorder.hs b/testsuite/tests/cmm/should_run/HooplPostorder.hs
new file mode 100644
index 0000000000..d7a8bbaef1
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/HooplPostorder.hs
@@ -0,0 +1,69 @@
+module Main where
+
+import Hoopl.Block
+import Hoopl.Collections
+import Hoopl.Graph
+import Hoopl.Label
+
+import Data.Maybe
+
+data TestBlock e x = TB { label_ :: Label, successors_ :: [Label] }
+    deriving (Eq, Show)
+
+instance NonLocal TestBlock where
+  entryLabel = label_
+  successors = successors_
+
+-- Test the classical diamond shape graph.
+test_diamond :: LabelMap (TestBlock C C)
+test_diamond = mapFromList $ map (\b -> (label_ b, b)) blocks
+  where
+    blocks =
+        [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 3]
+        , TB (mkHooplLabel 2) [mkHooplLabel 4]
+        , TB (mkHooplLabel 3) [mkHooplLabel 4]
+        , TB (mkHooplLabel 4) []
+        ]
+
+-- Test that the backedge doesn't change anything.
+test_diamond_backedge :: LabelMap (TestBlock C C)
+test_diamond_backedge = mapFromList $ map (\b -> (label_ b, b)) blocks
+  where
+    blocks =
+        [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 3]
+        , TB (mkHooplLabel 2) [mkHooplLabel 4]
+        , TB (mkHooplLabel 3) [mkHooplLabel 4]
+        , TB (mkHooplLabel 4) [mkHooplLabel 1]
+        ]
+
+-- Test that the "bypass" edge from 1 to 4 doesn't change anything.
+test_3 :: LabelMap (TestBlock C C)
+test_3 = mapFromList $ map (\b -> (label_ b, b)) blocks
+  where
+    blocks =
+        [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 4]
+        , TB (mkHooplLabel 2) [mkHooplLabel 4]
+        , TB (mkHooplLabel 4) []
+        ]
+
+-- Like test_3 but with different order of successors for the entry point.
+test_4 :: LabelMap (TestBlock C C)
+test_4 = mapFromList $ map (\b -> (label_ b, b)) blocks
+  where
+    blocks =
+        [ TB (mkHooplLabel 1) [mkHooplLabel 4, mkHooplLabel 2]
+        , TB (mkHooplLabel 2) [mkHooplLabel 4]
+        , TB (mkHooplLabel 4) []
+        ]
+
+
+main :: IO ()
+main = do
+    let result = revPostorderFrom test_diamond (mkHooplLabel 1)
+    putStrLn (show $ map label_ result)
+    let result = revPostorderFrom test_diamond_backedge (mkHooplLabel 1)
+    putStrLn (show $ map label_ result)
+    let result = revPostorderFrom test_3 (mkHooplLabel 1)
+    putStrLn (show $ map label_ result)
+    let result = revPostorderFrom test_4 (mkHooplLabel 1)
+    putStrLn (show $ map label_ result)
diff --git a/testsuite/tests/cmm/should_run/HooplPostorder.stdout b/testsuite/tests/cmm/should_run/HooplPostorder.stdout
new file mode 100644
index 0000000000..7e704c224b
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/HooplPostorder.stdout
@@ -0,0 +1,4 @@
+[L1,L3,L2,L4]
+[L1,L3,L2,L4]
+[L1,L2,L4]
+[L1,L2,L4]
diff --git a/testsuite/tests/cmm/should_run/Makefile b/testsuite/tests/cmm/should_run/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/cmm/should_run/all.T b/testsuite/tests/cmm/should_run/all.T
new file mode 100644
index 0000000000..00838075cf
--- /dev/null
+++ b/testsuite/tests/cmm/should_run/all.T
@@ -0,0 +1,4 @@
+test('HooplPostorder',
+     extra_run_opts('"' + config.libdir + '"'),
+     compile_and_run,
+     ['-package ghc'])