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