Hoopl: improve postorder calculation
[ghc.git] / testsuite / tests / cmm / should_run / HooplPostorder.hs
1 module Main where
2
3 import Hoopl.Block
4 import Hoopl.Collections
5 import Hoopl.Graph
6 import Hoopl.Label
7
8 import Data.Maybe
9
10 data TestBlock e x = TB { label_ :: Label, successors_ :: [Label] }
11 deriving (Eq, Show)
12
13 instance NonLocal TestBlock where
14 entryLabel = label_
15 successors = successors_
16
17 -- Test the classical diamond shape graph.
18 test_diamond :: LabelMap (TestBlock C C)
19 test_diamond = mapFromList $ map (\b -> (label_ b, b)) blocks
20 where
21 blocks =
22 [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 3]
23 , TB (mkHooplLabel 2) [mkHooplLabel 4]
24 , TB (mkHooplLabel 3) [mkHooplLabel 4]
25 , TB (mkHooplLabel 4) []
26 ]
27
28 -- Test that the backedge doesn't change anything.
29 test_diamond_backedge :: LabelMap (TestBlock C C)
30 test_diamond_backedge = mapFromList $ map (\b -> (label_ b, b)) blocks
31 where
32 blocks =
33 [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 3]
34 , TB (mkHooplLabel 2) [mkHooplLabel 4]
35 , TB (mkHooplLabel 3) [mkHooplLabel 4]
36 , TB (mkHooplLabel 4) [mkHooplLabel 1]
37 ]
38
39 -- Test that the "bypass" edge from 1 to 4 doesn't change anything.
40 test_3 :: LabelMap (TestBlock C C)
41 test_3 = mapFromList $ map (\b -> (label_ b, b)) blocks
42 where
43 blocks =
44 [ TB (mkHooplLabel 1) [mkHooplLabel 2, mkHooplLabel 4]
45 , TB (mkHooplLabel 2) [mkHooplLabel 4]
46 , TB (mkHooplLabel 4) []
47 ]
48
49 -- Like test_3 but with different order of successors for the entry point.
50 test_4 :: LabelMap (TestBlock C C)
51 test_4 = mapFromList $ map (\b -> (label_ b, b)) blocks
52 where
53 blocks =
54 [ TB (mkHooplLabel 1) [mkHooplLabel 4, mkHooplLabel 2]
55 , TB (mkHooplLabel 2) [mkHooplLabel 4]
56 , TB (mkHooplLabel 4) []
57 ]
58
59
60 main :: IO ()
61 main = do
62 let result = revPostorderFrom test_diamond (mkHooplLabel 1)
63 putStrLn (show $ map label_ result)
64 let result = revPostorderFrom test_diamond_backedge (mkHooplLabel 1)
65 putStrLn (show $ map label_ result)
66 let result = revPostorderFrom test_3 (mkHooplLabel 1)
67 putStrLn (show $ map label_ result)
68 let result = revPostorderFrom test_4 (mkHooplLabel 1)
69 putStrLn (show $ map label_ result)