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