1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
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)
|
