50e5a7e45156026dc7f3895ac6ea79fd50f6589e
[packages/hoopl.git] / src / Compiler / Hoopl / GraphUtil.hs
1 {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-}
2 #if __GLASGOW_HASKELL__ >= 701
3 {-# LANGUAGE Safe #-}
4 #endif
5
6 -- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint
7
8 module Compiler.Hoopl.GraphUtil
9 ( splice, gSplice , cat , bodyGraph, bodyUnion
10 , frontBiasBlock, backBiasBlock
11 )
12
13 where
14
15 import Compiler.Hoopl.Collections
16 import Compiler.Hoopl.Graph
17 import Compiler.Hoopl.Label
18
19 bodyGraph :: Body n -> Graph n C C
20 bodyGraph b = GMany NothingO b NothingO
21
22 splice :: forall block n e a x . NonLocal (block n) =>
23 (forall e x . block n e O -> block n O x -> block n e x)
24 -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x)
25 splice bcat = sp
26 where sp :: forall e a x .
27 Graph' block n e a -> Graph' block n a x -> Graph' block n e x
28
29 sp GNil g2 = g2
30 sp g1 GNil = g1
31
32 sp (GUnit b1) (GUnit b2) = {-# SCC "sp1" #-} GUnit $! b1 `bcat` b2
33
34 sp (GUnit b) (GMany (JustO e) bs x) = {-# SCC "sp2" #-} GMany (JustO (b `bcat` e)) bs x
35
36 sp (GMany e bs (JustO x)) (GUnit b2) = {-# SCC "sp3" #-} GMany e bs (JustO (x `bcat` b2))
37
38 sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2)
39 = {-# SCC "sp4" #-} GMany e1 (b1 `bodyUnion` b2) x2
40 where b1 = addBlock (x1 `bcat` e2) bs1
41
42 sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2)
43 = {-# SCC "sp5" #-} GMany e1 (b1 `bodyUnion` b2) x2
44
45 sp _ _ = error "bogus GADT match failure"
46
47 bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a
48 bodyUnion = mapUnionWithKey nodups
49 where nodups l _ _ = error $ "duplicate blocks with label " ++ show l
50
51 gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x
52 gSplice = splice cat
53
54 cat :: Block n e O -> Block n O x -> Block n e x
55 cat x y = case x of
56 BNil -> y
57
58 BlockCO l b1 -> case y of
59 BlockOC b2 n -> BlockCC l (b1 `cat` b2) n
60 BNil -> x
61 BMiddle n -> BlockCO l (b1 `BHead` n)
62 BCat{} -> BlockCO l (b1 `BCat` y)
63 BHead{} -> BlockCO l (b1 `BCat` y)
64 BTail{} -> BlockCO l (b1 `BCat` y)
65
66 BMiddle n -> case y of
67 BlockOC b2 n2 -> BlockOC (n `BTail` b2) n2
68 BNil -> x
69 BMiddle{} -> BTail n y
70 BCat{} -> BTail n y
71 BHead{} -> BTail n y
72 BTail{} -> BTail n y
73
74 BCat{} -> case y of
75 BlockOC b3 n2 -> BlockOC (x `cat` b3) n2
76 BNil -> x
77 BMiddle n -> BHead x n
78 BCat{} -> BCat x y
79 BHead{} -> BCat x y
80 BTail{} -> BCat x y
81
82 BHead{} -> case y of
83 BlockOC b2 n2 -> BlockOC (x `cat` b2) n2
84 BNil -> x
85 BMiddle n -> BHead x n
86 BCat{} -> BCat x y
87 BHead{} -> BCat x y
88 BTail{} -> BCat x y
89
90
91 BTail{} -> case y of
92 BlockOC b2 n2 -> BlockOC (x `BCat` b2) n2
93 BNil -> x
94 BMiddle n -> BHead x n
95 BCat{} -> BCat x y
96 BHead{} -> BCat x y
97 BTail{} -> BCat x y
98
99 ----------------------------------------------------------------
100
101 -- | A block is "front biased" if the left child of every
102 -- concatenation operation is a node, not a general block; a
103 -- front-biased block is analogous to an ordinary list. If a block is
104 -- front-biased, then its nodes can be traversed from front to back
105 -- without general recusion; tail recursion suffices. Not all shapes
106 -- can be front-biased; a closed/open block is inherently back-biased.
107
108 frontBiasBlock :: Block n e x -> Block n e x
109 frontBiasBlock blk = case blk of
110 BlockCO f b -> BlockCO f (fb b BNil)
111 BlockOC b n -> BlockOC (fb b BNil) n
112 BlockCC f b n -> BlockCC f (fb b BNil) n
113 b@BNil{} -> fb b BNil
114 b@BMiddle{} -> fb b BNil
115 b@BCat{} -> fb b BNil
116 b@BHead{} -> fb b BNil
117 b@BTail{} -> fb b BNil
118 where
119 fb :: Block n O O -> Block n O O -> Block n O O
120 fb BNil rest = rest
121 fb (BMiddle n) rest = BTail n rest
122 fb (BCat l r) rest = fb l (fb r rest)
123 fb (BTail n b) rest = BTail n (fb b rest)
124 fb (BHead b n) rest = fb b (BTail n rest)
125
126 -- | A block is "back biased" if the right child of every
127 -- concatenation operation is a node, not a general block; a
128 -- back-biased block is analogous to a snoc-list. If a block is
129 -- back-biased, then its nodes can be traversed from back to back
130 -- without general recusion; tail recursion suffices. Not all shapes
131 -- can be back-biased; an open/closed block is inherently front-biased.
132
133 backBiasBlock :: Block n e x -> Block n e x
134 backBiasBlock blk = case blk of
135 BlockCO f b -> BlockCO f (bb BNil b)
136 BlockOC b n -> BlockOC (bb BNil b) n
137 BlockCC f b n -> BlockCC f (bb BNil b) n
138 b@BNil{} -> bb BNil b
139 b@BMiddle{} -> bb BNil b
140 b@BCat{} -> bb BNil b
141 b@BHead{} -> bb BNil b
142 b@BTail{} -> bb BNil b
143 where
144 bb :: Block n O O -> Block n O O -> Block n O O
145 bb rest BNil = rest
146 bb rest (BMiddle n) = BHead rest n
147 bb rest (BCat l r) = bb (bb rest l) r
148 bb rest (BTail n b) = bb (BHead rest n) b
149 bb rest (BHead b n) = BHead (bb rest b) n