never executed always true always false
1 {-# LANGUAGE DataKinds #-}
2 {-# LANGUAGE DeriveFunctor #-}
3 {-# LANGUAGE GADTs #-}
4 {-# LANGUAGE PolyKinds #-}
5 {-# LANGUAGE RankNTypes #-}
6 {-# LANGUAGE ScopedTypeVariables #-}
7 {-# LANGUAGE StandaloneDeriving #-}
8 {-# LANGUAGE TypeFamilies #-}
9 module GHC.Cmm.Dataflow.Block
10 ( Extensibility (..)
11 , O
12 , C
13 , MaybeO(..)
14 , IndexedCO
15 , Block(..)
16 , blockAppend
17 , blockCons
18 , blockFromList
19 , blockJoin
20 , blockJoinHead
21 , blockJoinTail
22 , blockSnoc
23 , blockSplit
24 , blockSplitHead
25 , blockSplitTail
26 , blockToList
27 , emptyBlock
28 , firstNode
29 , foldBlockNodesB
30 , foldBlockNodesB3
31 , foldBlockNodesF
32 , isEmptyBlock
33 , lastNode
34 , mapBlock
35 , mapBlock'
36 , mapBlock3'
37 , replaceFirstNode
38 , replaceLastNode
39 ) where
40
41 import GHC.Prelude
42
43 -- -----------------------------------------------------------------------------
44 -- Shapes: Open and Closed
45
46 -- | Used at the type level to indicate "open" vs "closed" structure.
47 data Extensibility
48 -- | An "open" structure with a unique, unnamed control-flow edge flowing in
49 -- or out. \"Fallthrough\" and concatenation are permitted at an open point.
50 = Open
51 -- | A "closed" structure which supports control transfer only through the use
52 -- of named labels---no "fallthrough" is permitted. The number of control-flow
53 -- edges is unconstrained.
54 | Closed
55
56 type O = 'Open
57 type C = 'Closed
58
59 -- | Either type indexed by closed/open using type families
60 type family IndexedCO (ex :: Extensibility) (a :: k) (b :: k) :: k
61 type instance IndexedCO C a _b = a
62 type instance IndexedCO O _a b = b
63
64 -- | Maybe type indexed by open/closed
65 data MaybeO ex t where
66 JustO :: t -> MaybeO O t
67 NothingO :: MaybeO C t
68
69 deriving instance Functor (MaybeO ex)
70
71 -- -----------------------------------------------------------------------------
72 -- The Block type
73
74 -- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C).
75 -- Open at the entry means single entry, mutatis mutandis for exit.
76 -- A closed/closed block is a /basic/ block and can't be extended further.
77 -- Clients should avoid manipulating blocks and should stick to either nodes
78 -- or graphs.
79 data Block n e x where
80 BlockCO :: n C O -> Block n O O -> Block n C O
81 BlockCC :: n C O -> Block n O O -> n O C -> Block n C C
82 BlockOC :: Block n O O -> n O C -> Block n O C
83
84 BNil :: Block n O O
85 BMiddle :: n O O -> Block n O O
86 BCat :: Block n O O -> Block n O O -> Block n O O
87 BSnoc :: Block n O O -> n O O -> Block n O O
88 BCons :: n O O -> Block n O O -> Block n O O
89
90
91 -- -----------------------------------------------------------------------------
92 -- Simple operations on Blocks
93
94 -- Predicates
95
96 isEmptyBlock :: Block n e x -> Bool
97 isEmptyBlock BNil = True
98 isEmptyBlock (BCat l r) = isEmptyBlock l && isEmptyBlock r
99 isEmptyBlock _ = False
100
101
102 -- Building
103
104 emptyBlock :: Block n O O
105 emptyBlock = BNil
106
107 blockCons :: n O O -> Block n O x -> Block n O x
108 blockCons n b = case b of
109 BlockOC b l -> (BlockOC $! (n `blockCons` b)) l
110 BNil{} -> BMiddle n
111 BMiddle{} -> n `BCons` b
112 BCat{} -> n `BCons` b
113 BSnoc{} -> n `BCons` b
114 BCons{} -> n `BCons` b
115
116 blockSnoc :: Block n e O -> n O O -> Block n e O
117 blockSnoc b n = case b of
118 BlockCO f b -> BlockCO f $! (b `blockSnoc` n)
119 BNil{} -> BMiddle n
120 BMiddle{} -> b `BSnoc` n
121 BCat{} -> b `BSnoc` n
122 BSnoc{} -> b `BSnoc` n
123 BCons{} -> b `BSnoc` n
124
125 blockJoinHead :: n C O -> Block n O x -> Block n C x
126 blockJoinHead f (BlockOC b l) = BlockCC f b l
127 blockJoinHead f b = BlockCO f BNil `cat` b
128
129 blockJoinTail :: Block n e O -> n O C -> Block n e C
130 blockJoinTail (BlockCO f b) t = BlockCC f b t
131 blockJoinTail b t = b `cat` BlockOC BNil t
132
133 blockJoin :: n C O -> Block n O O -> n O C -> Block n C C
134 blockJoin f b t = BlockCC f b t
135
136 blockAppend :: Block n e O -> Block n O x -> Block n e x
137 blockAppend = cat
138
139
140 -- Taking apart
141
142 firstNode :: Block n C x -> n C O
143 firstNode (BlockCO n _) = n
144 firstNode (BlockCC n _ _) = n
145
146 lastNode :: Block n x C -> n O C
147 lastNode (BlockOC _ n) = n
148 lastNode (BlockCC _ _ n) = n
149
150 blockSplitHead :: Block n C x -> (n C O, Block n O x)
151 blockSplitHead (BlockCO n b) = (n, b)
152 blockSplitHead (BlockCC n b t) = (n, BlockOC b t)
153
154 blockSplitTail :: Block n e C -> (Block n e O, n O C)
155 blockSplitTail (BlockOC b n) = (b, n)
156 blockSplitTail (BlockCC f b t) = (BlockCO f b, t)
157
158 -- | Split a closed block into its entry node, open middle block, and
159 -- exit node.
160 blockSplit :: Block n C C -> (n C O, Block n O O, n O C)
161 blockSplit (BlockCC f b t) = (f, b, t)
162
163 blockToList :: Block n O O -> [n O O]
164 blockToList b = go b []
165 where go :: Block n O O -> [n O O] -> [n O O]
166 go BNil r = r
167 go (BMiddle n) r = n : r
168 go (BCat b1 b2) r = go b1 $! go b2 r
169 go (BSnoc b1 n) r = go b1 (n:r)
170 go (BCons n b1) r = n : go b1 r
171
172 blockFromList :: [n O O] -> Block n O O
173 blockFromList = foldr BCons BNil
174
175 -- Modifying
176
177 replaceFirstNode :: Block n C x -> n C O -> Block n C x
178 replaceFirstNode (BlockCO _ b) f = BlockCO f b
179 replaceFirstNode (BlockCC _ b n) f = BlockCC f b n
180
181 replaceLastNode :: Block n x C -> n O C -> Block n x C
182 replaceLastNode (BlockOC b _) n = BlockOC b n
183 replaceLastNode (BlockCC l b _) n = BlockCC l b n
184
185 -- -----------------------------------------------------------------------------
186 -- General concatenation
187
188 cat :: Block n e O -> Block n O x -> Block n e x
189 cat x y = case x of
190 BNil -> y
191
192 BlockCO l b1 -> case y of
193 BlockOC b2 n -> (BlockCC l $! (b1 `cat` b2)) n
194 BNil -> x
195 BMiddle _ -> BlockCO l $! (b1 `cat` y)
196 BCat{} -> BlockCO l $! (b1 `cat` y)
197 BSnoc{} -> BlockCO l $! (b1 `cat` y)
198 BCons{} -> BlockCO l $! (b1 `cat` y)
199
200 BMiddle n -> case y of
201 BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
202 BNil -> x
203 BMiddle{} -> BCons n y
204 BCat{} -> BCons n y
205 BSnoc{} -> BCons n y
206 BCons{} -> BCons n y
207
208 BCat{} -> case y of
209 BlockOC b3 n2 -> (BlockOC $! (x `cat` b3)) n2
210 BNil -> x
211 BMiddle n -> BSnoc x n
212 BCat{} -> BCat x y
213 BSnoc{} -> BCat x y
214 BCons{} -> BCat x y
215
216 BSnoc{} -> case y of
217 BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
218 BNil -> x
219 BMiddle n -> BSnoc x n
220 BCat{} -> BCat x y
221 BSnoc{} -> BCat x y
222 BCons{} -> BCat x y
223
224
225 BCons{} -> case y of
226 BlockOC b2 n2 -> (BlockOC $! (x `cat` b2)) n2
227 BNil -> x
228 BMiddle n -> BSnoc x n
229 BCat{} -> BCat x y
230 BSnoc{} -> BCat x y
231 BCons{} -> BCat x y
232
233
234 -- -----------------------------------------------------------------------------
235 -- Mapping
236
237 -- | map a function over the nodes of a 'Block'
238 mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x
239 mapBlock f (BlockCO n b ) = BlockCO (f n) (mapBlock f b)
240 mapBlock f (BlockOC b n) = BlockOC (mapBlock f b) (f n)
241 mapBlock f (BlockCC n b m) = BlockCC (f n) (mapBlock f b) (f m)
242 mapBlock _ BNil = BNil
243 mapBlock f (BMiddle n) = BMiddle (f n)
244 mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2)
245 mapBlock f (BSnoc b n) = BSnoc (mapBlock f b) (f n)
246 mapBlock f (BCons n b) = BCons (f n) (mapBlock f b)
247
248 -- | A strict 'mapBlock'
249 mapBlock' :: (forall e x. n e x -> n' e x) -> (Block n e x -> Block n' e x)
250 mapBlock' f = mapBlock3' (f, f, f)
251
252 -- | map over a block, with different functions to apply to first nodes,
253 -- middle nodes and last nodes respectively. The map is strict.
254 --
255 mapBlock3' :: forall n n' e x .
256 ( n C O -> n' C O
257 , n O O -> n' O O,
258 n O C -> n' O C)
259 -> Block n e x -> Block n' e x
260 mapBlock3' (f, m, l) b = go b
261 where go :: forall e x . Block n e x -> Block n' e x
262 go (BlockOC b y) = (BlockOC $! go b) $! l y
263 go (BlockCO x b) = (BlockCO $! f x) $! (go b)
264 go (BlockCC x b y) = ((BlockCC $! f x) $! go b) $! (l y)
265 go BNil = BNil
266 go (BMiddle n) = BMiddle $! m n
267 go (BCat x y) = (BCat $! go x) $! (go y)
268 go (BSnoc x n) = (BSnoc $! go x) $! (m n)
269 go (BCons n x) = (BCons $! m n) $! (go x)
270
271 -- -----------------------------------------------------------------------------
272 -- Folding
273
274
275 -- | Fold a function over every node in a block, forward or backward.
276 -- The fold function must be polymorphic in the shape of the nodes.
277 foldBlockNodesF3 :: forall n a b c .
278 ( n C O -> a -> b
279 , n O O -> b -> b
280 , n O C -> b -> c)
281 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
282 foldBlockNodesF :: forall n a .
283 (forall e x . n e x -> a -> a)
284 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
285 foldBlockNodesB3 :: forall n a b c .
286 ( n C O -> b -> c
287 , n O O -> b -> b
288 , n O C -> a -> b)
289 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
290 foldBlockNodesB :: forall n a .
291 (forall e x . n e x -> a -> a)
292 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
293
294 foldBlockNodesF3 (ff, fm, fl) = block
295 where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
296 block (BlockCO f b ) = ff f `cat` block b
297 block (BlockCC f b l) = ff f `cat` block b `cat` fl l
298 block (BlockOC b l) = block b `cat` fl l
299 block BNil = id
300 block (BMiddle node) = fm node
301 block (b1 `BCat` b2) = block b1 `cat` block b2
302 block (b1 `BSnoc` n) = block b1 `cat` fm n
303 block (n `BCons` b2) = fm n `cat` block b2
304 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
305 cat f f' = f' . f
306
307 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
308
309 foldBlockNodesB3 (ff, fm, fl) = block
310 where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
311 block (BlockCO f b ) = ff f `cat` block b
312 block (BlockCC f b l) = ff f `cat` block b `cat` fl l
313 block (BlockOC b l) = block b `cat` fl l
314 block BNil = id
315 block (BMiddle node) = fm node
316 block (b1 `BCat` b2) = block b1 `cat` block b2
317 block (b1 `BSnoc` n) = block b1 `cat` fm n
318 block (n `BCons` b2) = fm n `cat` block b2
319 cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
320 cat f f' = f . f'
321
322 foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
323