Make Hoopl work with MonoLocalBinds.
[packages/hoopl.git] / src / Compiler / Hoopl / XUtil.hs
1 {-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-}
2
3 -- | Utilities for clients of Hoopl, not used internally.
4
5 module Compiler.Hoopl.XUtil
6 ( firstXfer, distributeXfer
7 , distributeFact, distributeFactBwd
8 , successorFacts
9 , joinFacts
10 , joinOutFacts -- deprecated
11 , joinMaps
12 , foldGraphNodes
13 , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3
14 , tfFoldBlock
15 , ScottBlock(ScottBlock), scottFoldBlock
16 , fbnf3
17 , blockToNodeList, blockOfNodeList
18 , blockToNodeList' -- alternate version using fold
19 , blockToNodeList'' -- alternate version using scottFoldBlock
20 , blockToNodeList''' -- alternate version using tfFoldBlock
21 , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody
22 , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx
23 , noEntries
24 , BlockResult(..), lookupBlock
25 )
26 where
27
28 import qualified Data.Map as M
29 import Data.Maybe
30
31 import Compiler.Hoopl.Checkpoint
32 import Compiler.Hoopl.Collections
33 import Compiler.Hoopl.Dataflow
34 import Compiler.Hoopl.Graph
35 import Compiler.Hoopl.Label
36 import Compiler.Hoopl.Util
37
38
39 -- | Forward dataflow analysis and rewriting for the special case of a Body.
40 -- A set of entry points must be supplied; blocks not reachable from
41 -- the set are thrown away.
42 analyzeAndRewriteFwdBody
43 :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
44 => FwdPass m n f
45 -> entries -> Body n -> FactBase f
46 -> m (Body n, FactBase f)
47
48 -- | Backward dataflow analysis and rewriting for the special case of a Body.
49 -- A set of entry points must be supplied; blocks not reachable from
50 -- the set are thrown away.
51 analyzeAndRewriteBwdBody
52 :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries)
53 => BwdPass m n f
54 -> entries -> Body n -> FactBase f
55 -> m (Body n, FactBase f)
56
57 analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en))
58 analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en))
59
60 mapBodyFacts :: (Monad m)
61 => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f))
62 -> (Body n -> FactBase f -> m (Body n, FactBase f))
63 -- ^ Internal utility; should not escape
64 mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts
65 where -- the type constraint is needed for the pattern match;
66 -- if it were not, we would use do-notation here.
67 bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f)
68 bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb)
69
70 {-
71 Can't write:
72
73 do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f
74 return (body, fb)
75
76 because we need an explicit type signature in order to do the GADT
77 pattern matches on NothingO
78 -}
79
80
81
82 -- | Forward dataflow analysis and rewriting for the special case of a
83 -- graph open at the entry. This special case relieves the client
84 -- from having to specify a type signature for 'NothingO', which beginners
85 -- might find confusing and experts might find annoying.
86 analyzeAndRewriteFwdOx
87 :: forall m n f x. (CheckpointMonad m, NonLocal n)
88 => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f)
89
90 -- | Backward dataflow analysis and rewriting for the special case of a
91 -- graph open at the entry. This special case relieves the client
92 -- from having to specify a type signature for 'NothingO', which beginners
93 -- might find confusing and experts might find annoying.
94 analyzeAndRewriteBwdOx
95 :: forall m n f x. (CheckpointMonad m, NonLocal n)
96 => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f)
97
98 -- | A value that can be used for the entry point of a graph open at the entry.
99 noEntries :: MaybeC O Label
100 noEntries = NothingC
101
102 analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f
103 analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip
104 where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c)
105 strip (a, b, JustO c) = return (a, b, c)
106
107
108
109
110
111 -- | A utility function so that a transfer function for a first
112 -- node can be given just a fact; we handle the lookup. This
113 -- function is planned to be made obsolete by changes in the dataflow
114 -- interface.
115
116 firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f)
117 firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb
118
119 -- | This utility function handles a common case in which a transfer function
120 -- produces a single fact out of a last node, which is then distributed
121 -- over the outgoing edges.
122 distributeXfer :: NonLocal n
123 => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f)
124 distributeXfer lattice xfer n f =
125 mkFactBase lattice [ (l, xfer n f) | l <- successors n ]
126
127 -- | This utility function handles a common case in which a transfer function
128 -- for a last node takes the incoming fact unchanged and simply distributes
129 -- that fact over the outgoing edges.
130 distributeFact :: NonLocal n => n O C -> f -> FactBase f
131 distributeFact n f = mapFromList [ (l, f) | l <- successors n ]
132 -- because the same fact goes out on every edge,
133 -- there's no need for 'mkFactBase' here.
134
135 -- | This utility function handles a common case in which a backward transfer
136 -- function takes the incoming fact unchanged and tags it with the node's label.
137 distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f
138 distributeFactBwd n f = mapSingleton (entryLabel n) f
139
140 -- | List of (unlabelled) facts from the successors of a last node
141 successorFacts :: NonLocal n => n O C -> FactBase f -> [f]
142 successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ]
143
144 -- | Join a list of facts.
145 joinFacts :: DataflowLattice f -> Label -> [f] -> f
146 joinFacts lat inBlock = foldr extend (fact_bot lat)
147 where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new)
148
149 {-# DEPRECATED joinOutFacts
150 "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-}
151
152 joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f
153 joinOutFacts lat n f = foldr join (fact_bot lat) facts
154 where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new)
155 facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact]
156
157
158 -- | It's common to represent dataflow facts as a map from variables
159 -- to some fact about the locations. For these maps, the join
160 -- operation on the map can be expressed in terms of the join on each
161 -- element of the codomain:
162 joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v)
163 joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new
164 where
165 add k new_v (ch, joinmap) =
166 case M.lookup k joinmap of
167 Nothing -> (SomeChange, M.insert k new_v joinmap)
168 Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of
169 (SomeChange, v') -> (SomeChange, M.insert k v' joinmap)
170 (NoChange, _) -> (ch, joinmap)
171
172
173
174 -- | A fold function that relies on the IndexedCO type function.
175 -- Note that the type parameter e is available to the functions
176 -- that are applied to the middle and last nodes.
177 tfFoldBlock :: forall n bc bo c e x .
178 ( n C O -> bc
179 , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo
180 , n O C -> IndexedCO e bc bo -> c)
181 -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo))
182 tfFoldBlock (f, m, l) bl bo = block bl
183 where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo)
184 block (BFirst n) = f n
185 block (BMiddle n) = m n bo
186 block (BLast n) = l n bo
187 block (b1 `BCat` b2) = oblock b2 $ block b1
188 block (b1 `BClosed` b2) = oblock b2 $ block b1
189 block (b1 `BHead` n) = m n $ block b1
190 block (n `BTail` b2) = oblock b2 $ m n bo
191 oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo)
192 oblock (BMiddle n) = m n
193 oblock (BLast n) = l n
194 oblock (b1 `BCat` b2) = oblock b1 `cat` oblock b2
195 oblock (n `BTail` b2) = m n `cat` oblock b2
196 cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
197 cat f f' = f' . f
198
199
200 type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C))
201 blockToNodeList''' ::
202 forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n
203 , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) =>
204 Block n e x -> NodeList' e x n
205 blockToNodeList''' b = (h, reverse ms', t)
206 where
207 (h, ms', t) = tfFoldBlock (f, m, l) b z
208 z :: NodeList' O O n
209 z = (NothingC, [], NothingC)
210 f :: n C O -> NodeList' C O n
211 f n = (JustC n, [], NothingC)
212 m n (h, ms', t) = (h, n : ms', t)
213 l n (h, ms', _) = (h, ms', JustC n)
214
215
216 {-
217 data EitherCO' ex a b where
218 LeftCO :: a -> EitherCO' C a b
219 RightCO :: b -> EitherCO' O a b
220 -}
221
222 -- should be done with a *backward* fold
223
224 -- | More general fold
225
226 _unused :: Int
227 _unused = 3
228 where _a = foldBlockNodesF3'' (Trips undefined undefined undefined)
229 _b = foldBlockNodesF3'
230
231 data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b
232 , fm :: n O O -> b -> b
233 , fl :: forall x . MaybeC x (n O C) -> b -> c
234 }
235
236 foldBlockNodesF3'' :: forall n a b c .
237 Trips n a b c -> (forall e x . Block n e x -> a -> c)
238 foldBlockNodesF3'' trips = block
239 where block :: Block n e x -> a -> c
240 block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2
241 block (BFirst node) = ff trips (JustC node) `cat` missingLast
242 block (b @ BHead {}) = foldCO b `cat` missingLast
243 block (BMiddle node) = missingFirst `cat` fm trips node `cat` missingLast
244 block (b @ BCat {}) = missingFirst `cat` foldOO b `cat` missingLast
245 block (BLast node) = missingFirst `cat` fl trips (JustC node)
246 block (b @ BTail {}) = missingFirst `cat` foldOC b
247 missingLast = fl trips NothingC
248 missingFirst = ff trips NothingC
249 foldCO :: Block n C O -> a -> b
250 foldOO :: Block n O O -> b -> b
251 foldOC :: Block n O C -> b -> c
252 foldCO (BFirst n) = ff trips (JustC n)
253 foldCO (BHead b n) = foldCO b `cat` fm trips n
254 foldOO (BMiddle n) = fm trips n
255 foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2
256 foldOC (BLast n) = fl trips (JustC n)
257 foldOC (BTail n b) = fm trips n `cat` foldOC b
258 cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c
259 f `cat` g = g . f
260
261 data ScottBlock n a = ScottBlock
262 { sb_first :: n C O -> a C O
263 , sb_mid :: n O O -> a O O
264 , sb_last :: n O C -> a O C
265 , sb_cat :: forall e x . a e O -> a O x -> a e x
266 }
267
268 scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x
269 scottFoldBlock funs = block
270 where block :: forall e x . Block n e x -> a e x
271 block (BFirst n) = sb_first funs n
272 block (BMiddle n) = sb_mid funs n
273 block (BLast n) = sb_last funs n
274 block (BClosed b1 b2) = block b1 `cat` block b2
275 block (BCat b1 b2) = block b1 `cat` block b2
276 block (BHead b n) = block b `cat` sb_mid funs n
277 block (BTail n b) = sb_mid funs n `cat` block b
278 cat :: forall e x. a e O -> a O x -> a e x
279 cat = sb_cat funs
280
281 newtype NodeList n e x
282 = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) }
283
284 fbnf3 :: forall n a b c .
285 ( n C O -> a -> b
286 , n O O -> b -> b
287 , n O C -> b -> c)
288 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
289 fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block
290 where f n = FF3 $ ff n
291 m n = FF3 $ fm n
292 l n = FF3 $ fl n
293 -- XXX Ew.
294 cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x.
295 (IndexedCO x c b ~ IndexedCO t9 t7 t6,
296 IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1,
297 IndexedCO t3 t t1 ~ IndexedCO e a b) =>
298 FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x
299 FF3 f `cat` FF3 f' = FF3 $ f' . f
300
301 newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b }
302
303 blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
304 blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat)
305 where f n = NL (JustC n, id, NothingC)
306 m n = NL (NothingC, (n:), NothingC)
307 l n = NL (NothingC, id, JustC n)
308 cat :: forall n t1 t2 t3. NodeList n t1 t2 -> NodeList n t2 t3 -> NodeList n t1 t3
309 NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x)
310 finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2)
311 finish (e, ms, x) = (e, ms [], x)
312
313
314
315 blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
316 blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b ()
317 where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e
318 fm :: forall n e. n O O -> PNL n e -> PNL n e
319 fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x
320 ff n () = PNL (n, [])
321 fm n (PNL (first, mids')) = PNL (first, n : mids')
322 fl n (PNL (first, mids')) = FNL (first, reverse mids', n)
323
324 -- newtypes for 'partial node list' and 'final node list'
325 newtype PNL n e = PNL (MaybeC e (n C O), [n O O])
326 newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))}
327
328 foldBlockNodesF3''' :: forall n a b c .
329 (forall e . MaybeC e (n C O) -> a -> b e)
330 -> (forall e . n O O -> b e -> b e)
331 -> (forall e x . MaybeC x (n O C) -> b e -> c e x)
332 -> (forall e x . Block n e x -> a -> c e x)
333 foldBlockNodesF3''' ff fm fl = block
334 where block :: forall e x . Block n e x -> a -> c e x
335 blockCO :: Block n C O -> a -> b C
336 blockOO :: forall e . Block n O O -> b e -> b e
337 blockOC :: forall e . Block n O C -> b e -> c e C
338 block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2
339 block (BFirst node) = ff (JustC node) `cat` fl NothingC
340 block (b @ BHead {}) = blockCO b `cat` fl NothingC
341 block (BMiddle node) = ff NothingC `cat` fm node `cat` fl NothingC
342 block (b @ BCat {}) = ff NothingC `cat` blockOO b `cat` fl NothingC
343 block (BLast node) = ff NothingC `cat` fl (JustC node)
344 block (b @ BTail {}) = ff NothingC `cat` blockOC b
345 blockCO (BFirst n) = ff (JustC n)
346 blockCO (BHead b n) = blockCO b `cat` fm n
347 blockOO (BMiddle n) = fm n
348 blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
349 blockOC (BLast n) = fl (JustC n)
350 blockOC (BTail n b) = fm n `cat` blockOC b
351 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
352 f `cat` g = g . f
353
354
355 -- | The following function is easy enough to define but maybe not so useful
356 foldBlockNodesF3' :: forall n a b c .
357 ( n C O -> a -> b
358 , n O O -> b -> b
359 , n O C -> b -> c)
360 -> (a -> b) -- called iff there is no first node
361 -> (b -> c) -- called iff there is no last node
362 -> (forall e x . Block n e x -> a -> c)
363 foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block
364 where block :: forall e x . Block n e x -> a -> c
365 blockCO :: Block n C O -> a -> b
366 blockOO :: Block n O O -> b -> b
367 blockOC :: Block n O C -> b -> c
368 block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2
369 block (BFirst node) = ff node `cat` missingLast
370 block (b @ BHead {}) = blockCO b `cat` missingLast
371 block (BMiddle node) = missingFirst `cat` fm node `cat` missingLast
372 block (b @ BCat {}) = missingFirst `cat` blockOO b `cat` missingLast
373 block (BLast node) = missingFirst `cat` fl node
374 block (b @ BTail {}) = missingFirst `cat` blockOC b
375 blockCO (BFirst n) = ff n
376 blockCO (BHead b n) = blockCO b `cat` fm n
377 blockOO (BMiddle n) = fm n
378 blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2
379 blockOC (BLast n) = fl n
380 blockOC (BTail n b) = fm n `cat` blockOC b
381 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
382 f `cat` g = g . f
383
384 -- | Fold a function over every node in a block, forward or backward.
385 -- The fold function must be polymorphic in the shape of the nodes.
386 foldBlockNodesF3 :: forall n a b c .
387 ( n C O -> a -> b
388 , n O O -> b -> b
389 , n O C -> b -> c)
390 -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b)
391 foldBlockNodesF :: forall n a .
392 (forall e x . n e x -> a -> a)
393 -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a)
394 foldBlockNodesB3 :: forall n a b c .
395 ( n C O -> b -> c
396 , n O O -> b -> b
397 , n O C -> a -> b)
398 -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b)
399 foldBlockNodesB :: forall n a .
400 (forall e x . n e x -> a -> a)
401 -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a)
402 -- | Fold a function over every node in a graph.
403 -- The fold function must be polymorphic in the shape of the nodes.
404
405 foldGraphNodes :: forall n a .
406 (forall e x . n e x -> a -> a)
407 -> (forall e x . Graph n e x -> a -> a)
408
409
410 foldBlockNodesF3 (ff, fm, fl) = block
411 where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b
412 block (BFirst node) = ff node
413 block (BMiddle node) = fm node
414 block (BLast node) = fl node
415 block (b1 `BCat` b2) = block b1 `cat` block b2
416 block (b1 `BClosed` b2) = block b1 `cat` block b2
417 block (b1 `BHead` n) = block b1 `cat` fm n
418 block (n `BTail` b2) = fm n `cat` block b2
419 cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c
420 cat f f' = f' . f
421 foldBlockNodesF f = foldBlockNodesF3 (f, f, f)
422
423 foldBlockNodesB3 (ff, fm, fl) = block
424 where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b
425 block (BFirst node) = ff node
426 block (BMiddle node) = fm node
427 block (BLast node) = fl node
428 block (b1 `BCat` b2) = block b1 `cat` block b2
429 block (b1 `BClosed` b2) = block b1 `cat` block b2
430 block (b1 `BHead` n) = block b1 `cat` fm n
431 block (n `BTail` b2) = fm n `cat` block b2
432 cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c
433 cat f f' = f . f'
434 foldBlockNodesB f = foldBlockNodesB3 (f, f, f)
435
436
437 foldGraphNodes f = graph
438 where graph :: forall e x . Graph n e x -> a -> a
439 lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a)
440
441 graph GNil = id
442 graph (GUnit b) = block b
443 graph (GMany e b x) = lift block e . body b . lift block x
444 body :: Body n -> a -> a
445 body bdy = \a -> mapFold block a bdy
446 lift _ NothingO = id
447 lift f (JustO thing) = f thing
448
449 block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a
450 block = foldBlockNodesF f
451
452 {-# DEPRECATED blockToNodeList, blockOfNodeList
453 "What justifies these functions? Can they be eliminated? Replaced with folds?" #-}
454
455
456
457 -- | Convert a block to a list of nodes. The entry and exit node
458 -- is or is not present depending on the shape of the block.
459 --
460 -- The blockToNodeList function cannot be currently expressed using
461 -- foldBlockNodesB, because it returns IndexedCO e a b, which means
462 -- two different types depending on the shape of the block entry.
463 -- But blockToNodeList returns one of four possible types, depending
464 -- on the shape of the block entry *and* exit.
465 blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C))
466 blockToNodeList block = case block of
467 BFirst n -> (JustC n, [], NothingC)
468 BMiddle n -> (NothingC, [n], NothingC)
469 BLast n -> (NothingC, [], JustC n)
470 BCat {} -> (NothingC, foldOO block [], NothingC)
471 BHead x n -> case foldCO x [n] of (f, m) -> (f, m, NothingC)
472 BTail n x -> case foldOC x of (m, l) -> (NothingC, n : m, l)
473 BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l)
474 where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O])
475 foldCO (BFirst n) m = (JustC n, m)
476 foldCO (BHead x n) m = foldCO x (n : m)
477
478 foldOO :: Block n O O -> [n O O] -> [n O O]
479 foldOO (BMiddle n) acc = n : acc
480 foldOO (BCat x y) acc = foldOO x $ foldOO y acc
481
482 foldOC :: Block n O C -> ([n O O], MaybeC C (n O C))
483 foldOC (BLast n) = ([], JustC n)
484 foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l)
485
486 -- | Convert a list of nodes to a block. The entry and exit node
487 -- must or must not be present depending on the shape of the block.
488 blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x
489 blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList"
490 blockOfNodeList (NothingC, m, NothingC) = foldr1 BCat (map BMiddle m)
491 blockOfNodeList (NothingC, m, JustC l) = foldr BTail (BLast l) m
492 blockOfNodeList (JustC f, m, NothingC) = foldl BHead (BFirst f) m
493 blockOfNodeList (JustC f, m, JustC l) = BClosed (BFirst f) $ foldr BTail (BLast l) m
494
495 data BlockResult n x where
496 NoBlock :: BlockResult n x
497 BodyBlock :: Block n C C -> BlockResult n x
498 ExitBlock :: Block n C O -> BlockResult n O
499
500 lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x
501 lookupBlock (GMany _ _ (JustO exit)) lbl
502 | entryLabel exit == lbl = ExitBlock exit
503 lookupBlock (GMany _ body _) lbl =
504 case mapLookup lbl body of
505 Just b -> BodyBlock b
506 Nothing -> NoBlock
507 lookupBlock GNil _ = NoBlock
508 lookupBlock (GUnit _) _ = NoBlock