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