2 ( -- These data types and names are carefully thought out
3 Graph(..), LGraph(..), FGraph(..)
4 , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
6 , HavingSuccessors, succs, fold_succs
7 , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
9 -- Observers and transformers
10 -- (open to renaming suggestions here)
11 , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
12 , splice_tail, splice_head, splice_head_only', splice_head'
13 , of_block_list, to_block_list
15 , map_blocks, map_nodes, mapM_blocks
16 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
18 , fold_blocks, fold_fwd_block
23 , entry -- exported for the convenience of ZipDataflow0, at least for now
26 -- the following functions might one day be useful and can be found
27 -- either below or in ZipCfgExtras:
28 , entry, exit, focus, focusp, unfocus
29 , ht_to_block, ht_to_last,
30 , splice_focus_entry, splice_focus_exit
37 #include "HsVersions.h"
39 import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
42 import Outputable hiding (empty)
48 import Prelude hiding (zip, unzip, last)
50 -------------------------------------------------------------------------
51 -- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
52 -------------------------------------------------------------------------
55 This module defines datatypes used to represent control-flow graphs,
56 along with some functions for analyzing and splicing graphs.
57 Functions for building graphs are found in a separate module 'MkZipCfg'.
59 Every graph has a distinguished entry point. A graph has at least one
60 exit; most exits are instructions (or statements) like 'jump' or
61 'return', which transfer control to other procedures, but a graph may
62 have up to one 'fall through' exit. (A graph that represents an
63 entire Haskell or C-- procedure does not have a 'fall through' exit.)
65 A graph is a collection of basic blocks. A basic block begins with a
66 label (unique id; see Note [Unique BlockId]) which is followed by a
67 sequence of zero or more 'middle' nodes; the basic block ends with a
68 'last' node. Each 'middle' node is a single-entry, single-exit,
69 uninterruptible computation. A 'last' node is a single-entry,
70 multiple-exit computation. A last node may have zero or more successors,
71 which are identified by their unique ids.
73 A special case of last node is the ``default exit,'' which represents
74 'falling off the end' of the graph. Such a node is always represented by
75 the data constructor 'LastExit'. A graph may contain at most one
76 'LastExit' node, and a graph representing a full procedure should not
77 contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
78 graphs together, either during graph construction (see module 'MkZipCfg')
79 or during optimization (see module 'ZipDataflow0').
81 A graph is parameterized over the types of middle and last nodes. Each of
82 these types will typically be instantiated with a subset of C-- statements
83 (see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
84 implemented as of August 2007).
87 Note [Kinds of Graphs]
88 ~~~~~~~~~~~~~~~~~~~~~~
89 This module exposes three representations of graphs. In order of
90 increasing complexity, they are:
92 Graph m l The basic graph with its distinguished entry point
94 LGraph m l A graph with a *labelled* entry point
96 FGraph m l A labelled graph with the *focus* on a particular edge
98 There are three types because each type offers a slightly different
99 invariant or cost model.
101 * The distinguished entry of a Graph has no label. Because labels must be
102 unique, acquiring one requires a supply of Unique labels (BlockId's).
103 The primary advantage of the Graph representation is that we can build a
104 small Graph purely functionally, without needing a fresh BlockId or
105 Unique. For example, during optimization we can easily rewrite a single
106 middle node into a Graph containing a sequence of two middle nodes
107 followed by LastExit.
109 * In an LGraph, every basic block is labelled. The primary advantage of
110 this representation is its simplicity: each basic block can be treated
111 like any other. This representation is used for mapping, folding, and
112 translation, as well as layout.
114 Like any graph, an LGraph still has a distinguished entry point,
115 which you can discover using 'lg_entry'.
117 * An FGraph is an LGraph with the *focus* on one particular edge. The
118 primary advantage of this representation is that it provides
119 constant-time access to the nodes connected by that edge, and it also
120 allows constant-time, functional *replacement* of those nodes---in the
121 style of Huet's 'zipper'.
123 None of these representations is ideally suited to the incremental
124 construction of large graphs. A separate module, 'MkZipCfg', provides a
125 fourth representation that is asymptotically optimal for such construction.
129 --------------- Representation --------------------
131 -- | A basic block is a 'first' node, followed by zero or more 'middle'
132 -- nodes, followed by a 'last' node.
134 -- eventually this module should probably replace the original Cmm, but for
135 -- now we leave it to dynamic invariants what can be found where
138 = LastExit -- fall through; used for the block that has no last node
139 -- LastExit is a device used only for graphs under
140 -- construction, or framgments of graph under optimisation,
141 -- so we don't want to pollute the 'l' type parameter with it
144 --So that we don't have orphan instances, this goes here or in CmmExpr.
145 --At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
146 --but there's no need for non-Haskell98 instances for that.
147 instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
148 foldRegsUsed f z (LastOther l) = foldRegsUsed f z l
149 foldRegsUsed _f z LastExit = z
152 data ZHead m = ZFirst BlockId | ZHead (ZHead m) m
153 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
154 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
155 -- ZTail is a sequence of middle nodes followed by a last node
157 -- | Blocks and flow graphs; see Note [Kinds of graphs]
158 data Block m l = Block BlockId (ZTail m l)
160 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
162 data LGraph m l = LGraph { lg_entry :: BlockId
163 , lg_blocks :: BlockEnv (Block m l) }
164 -- Invariant: lg_entry is in domain( lg_blocks )
166 -- | And now the zipper. The focus is between the head and tail.
167 -- We cannot ever focus on an inter-block edge.
168 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
169 data FGraph m l = FGraph { fg_entry :: BlockId
170 , fg_focus :: ZBlock m l
171 , fg_others :: BlockEnv (Block m l) }
172 -- Invariant: the block represented by 'fg_focus' is *not*
173 -- in the map 'fg_others'
175 ---- Utility functions ---
177 blockId :: Block m l -> BlockId
178 zip :: ZBlock m l -> Block m l
179 unzip :: Block m l -> ZBlock m l
181 last :: ZBlock m l -> ZLast l
182 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
184 tailOfLast :: l -> ZTail m l
186 -- | Take a head and tail and go to beginning or end. The asymmetry
187 -- in the types and names is a bit unfortunate, but 'Block m l' is
188 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
190 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
191 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
193 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
194 -- For a head, we have a head 'h' followed by a LGraph 'g'.
195 -- The entry node of 'g' gets joined to 'h', forming the entry into
196 -- the new LGraph. The exit of 'g' becomes the new head.
197 -- For both arguments and results, the order of values is the order of
198 -- control flow: before splicing, the head flows into the LGraph; after
199 -- splicing, the LGraph flows into the head.
200 -- Splicing a tail is the dual operation.
201 -- (In order to maintain the order-means-control-flow convention, the
202 -- orders are reversed.)
204 -- For example, assume
206 -- grph = (M, [M: <stuff>,
208 -- N: y:=x; LastExit])
209 -- tail = [return (y,x)]
211 -- Then splice_head head grph
212 -- = ((L, [L: x:=0; goto M,
217 -- Then splice_tail grph tail
219 -- , (???, [<blocks>,
220 -- N: y:=x; return (y,x)])
222 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
223 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
224 splice_tail :: Graph m l -> ZTail m l -> Graph m l
226 -- | We can also splice a single-entry, no-exit Graph into a head.
227 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
228 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
231 -- | A safe operation
233 -- | Conversion to and from the environment form is convenient. For
234 -- layout or dataflow, however, one will want to use 'postorder_dfs'
235 -- in order to get the blocks in an order that relates to the control
236 -- flow in the procedure.
237 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
238 to_block_list :: LGraph m l -> [Block m l] -- N log N
240 -- | Conversion from LGraph to Graph
241 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
242 graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
245 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
246 -- from the entry node. This list has the following property:
248 -- Say a "back reference" exists if one of a block's
249 -- control-flow successors precedes it in the output list
251 -- Then there are as few back references as possible
253 -- The output is suitable for use in
254 -- a forward dataflow problem. For a backward problem, simply reverse
255 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
256 -- one doesn't want to try and maintain both forward and backward
259 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
261 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
262 -- in layout order. The 'Maybe BlockId', if present, identifies the
263 -- block that will be the layout successor of the current block. This
264 -- may be useful to help an emitter omit the final 'goto' of a block
265 -- that flows directly to its layout successor.
267 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
268 -- = z <$> f (L1:B1) (Just L2)
269 -- <$> f (L2:B2) (Just L3)
270 -- <$> f (L3:B3) Nothing
271 -- where a <$> f = f a
273 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
275 -- | We can also fold over blocks in an unspecified order. The
276 -- 'ZipCfgExtras' module provides a monadic version, which we
277 -- haven't needed (else it would be here).
278 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
280 -- | Fold from first to last
282 (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a
284 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
285 -- mapping includes the entry id!
287 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
288 mapM_blocks :: Monad mm
289 => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
291 -- | These translation functions are speculative. I hope eventually
292 -- they will be used in the native-code back ends ---NR
293 translate :: Monad tm =>
294 (m -> tm (LGraph m' l')) ->
295 (l -> tm (LGraph m' l')) ->
296 (LGraph m l -> tm (LGraph m' l'))
299 -- | It's possible that another form of translation would be more suitable:
300 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
303 ------------------- Last nodes
305 -- | We can't make a graph out of just any old 'last node' type. A last node
306 -- has to be able to find its successors, and we need to be able to create and
307 -- identify unconditional branches. We put these capabilities in a type class.
308 -- Moreover, the property of having successors is also shared by 'Block's and
309 -- 'ZTails', so it is useful to have that property in a type class of its own.
311 class HavingSuccessors b where
312 succs :: b -> [BlockId]
313 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
315 fold_succs add l z = foldr add z $ succs l
317 class HavingSuccessors l => LastNode l where
318 mkBranchNode :: BlockId -> l
319 isBranchNode :: l -> Bool
320 branchNodeTarget :: l -> BlockId -- panics if not branch node
321 -- ^ N.B. This interface seems to make for more congenial clients than a
322 -- single function of type 'l -> Maybe BlockId'
324 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
326 succs (LastOther l) = succs l
327 fold_succs _ LastExit z = z
328 fold_succs f (LastOther l) z = fold_succs f l z
330 instance LastNode l => LastNode (ZLast l) where
331 mkBranchNode id = LastOther $ mkBranchNode id
332 isBranchNode LastExit = False
333 isBranchNode (LastOther l) = isBranchNode l
334 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
335 branchNodeTarget (LastOther l) = branchNodeTarget l
337 instance LastNode l => HavingSuccessors (ZBlock m l) where
338 succs b = succs (last b)
340 instance LastNode l => HavingSuccessors (Block m l) where
341 succs b = succs (unzip b)
343 instance LastNode l => HavingSuccessors (ZTail m l) where
344 succs b = succs (lastTail b)
348 -- ================ IMPLEMENTATION ================--
350 ----- block manipulations
352 blockId (Block id _) = id
354 -- | Convert block between forms.
355 -- These functions are tail-recursive, so we can go as deep as we like
356 -- without fear of stack overflow.
358 ht_to_block head tail = case head of
359 ZFirst id -> Block id tail
360 ZHead h m -> ht_to_block h (ZTail m tail)
362 ht_to_last head (ZLast l) = (head, l)
363 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
365 zipht h t = ht_to_block h t
366 zip (ZBlock h t) = ht_to_block h t
367 goto_end (ZBlock h t) = ht_to_last h t
369 unzip (Block id t) = ZBlock (ZFirst id) t
371 head_id :: ZHead m -> BlockId
372 head_id (ZFirst id) = id
373 head_id (ZHead h _) = head_id h
375 last (ZBlock _ t) = lastTail t
377 lastTail :: ZTail m l -> ZLast l
378 lastTail (ZLast l) = l
379 lastTail (ZTail _ t) = lastTail t
381 tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client
384 ------------------ simple graph manipulations
386 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
387 focus id (LGraph entry blocks) =
388 case lookupBlockEnv blocks id of
389 Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
390 Nothing -> panic "asked for nonexistent block in flow graph"
392 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
393 entry g@(LGraph eid _) = focus eid g
395 -- | pull out a block satisfying the predicate, if any
396 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
397 Maybe (Block m l, BlockEnv (Block m l))
398 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
399 where scan b (yes, no) =
401 Nothing | p b -> (Just b, no)
402 | otherwise -> (yes, insertBlock b no)
403 Just _ -> (yes, insertBlock b no)
404 lift (Nothing, _) = Nothing
405 lift (Just b, bs) = Just (b, bs)
407 -- | 'insertBlock' should not be used to *replace* an existing block
408 -- but only to insert a new one
409 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
411 ASSERT (isNothing $ lookupBlockEnv bs id)
412 extendBlockEnv bs id b
415 -- | Used in assertions; tells if a graph has exactly one exit
416 single_exit :: LGraph l m -> Bool
417 single_exit g = foldUFM check 0 (lg_blocks g) == 1
418 where check block count = case last (unzip block) of
419 LastExit -> count + (1 :: Int)
422 -- | Used in assertions; tells if a graph has exactly one exit
423 single_exitg :: Graph l m -> Bool
424 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
425 where add block count = count + exit_count (last (unzip block))
426 exit_count LastExit = 1 :: Int
429 ------------------ graph traversals
431 -- | This is the most important traversal over this data structure. It drops
432 -- unreachable code and puts blocks in an order that is good for solving forward
433 -- dataflow problems quickly. The reverse order is good for solving backward
434 -- dataflow problems quickly. The forward order is also reasonably good for
435 -- emitting instructions, except that it will not usually exploit Forrest
436 -- Baskett's trick of eliminating the unconditional branch from a loop. For
437 -- that you would need a more serious analysis, probably based on dominators, to
438 -- identify loop headers.
440 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
441 -- representation, when for most purposes the plain 'Graph' representation is
442 -- more mathematically elegant (but results in more complicated code).
444 -- Here's an easy way to go wrong! Consider
448 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
449 -- Better to geot [A,B,C,D]
452 postorder_dfs g@(LGraph _ blockenv) =
453 let FGraph id eblock _ = entry g in
454 zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
456 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
457 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
458 postorder_dfs_from_except blocks b visited =
459 vchildren (get_children b) (\acc _visited -> acc) [] visited
462 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
463 vnode block@(Block id _) cont acc visited =
464 if elemBlockSet id visited then
467 let cont' acc visited = cont (block:acc) visited in
468 vchildren (get_children block) cont' acc (extendBlockSet visited id)
469 vchildren bs cont acc visited =
470 let next children acc visited =
471 case children of [] -> cont acc visited
472 (b:bs) -> vnode b (next bs) acc visited
473 in next bs acc visited
474 get_children block = foldl add_id [] (succs block)
475 add_id rst id = case lookupBlockEnv blocks id of
480 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
481 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
485 -- | Slightly more complicated than the usual fold because we want to tell block
486 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
487 -- 'goto b2', the goto can be omitted.
489 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
490 where fold blocks z =
491 case blocks of [] -> z
493 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
494 nextlabel (Block id _) =
495 if id == eid then panic "entry as successor"
498 -- | The rest of the traversals are straightforward
500 map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)
502 map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
503 where block (Block id t) = Block (idm id) (tail t)
504 tail (ZTail m t) = ZTail (middle m) (tail t)
505 tail (ZLast LastExit) = ZLast LastExit
506 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
509 mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
511 foldUFM (\b mblocks -> do { blocks <- mblocks
513 ; return $ insertBlock b blocks })
514 (return emptyBlockEnv) blocks
516 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
517 fold_fwd_block first middle last (Block id t) z = tail t (first id z)
518 where tail (ZTail m t) z = tail t (middle m z)
519 tail (ZLast l) z = last l z
521 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
522 to_block_list (LGraph _ blocks) = eltsUFM blocks
527 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
528 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
529 -- or it isn't. We use continuation-passing style.
531 prepare_for_splicing ::
532 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
534 prepare_for_splicing g single multi =
535 let FGraph _ gentry gblocks = entry g
536 ZBlock _ etail = gentry
537 in if isNullUFM gblocks then
539 LastExit -> single etail
540 _ -> panic "bad single block"
542 case splitp_blocks is_exit gblocks of
543 Nothing -> panic "Can't find an exit block"
544 Just (gexit, gblocks) ->
545 let (gh, gl) = goto_end $ unzip gexit in
546 case gl of LastExit -> multi etail gh gblocks
547 _ -> panic "exit is not exit?!"
549 prepare_for_splicing' ::
550 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
552 prepare_for_splicing' (Graph etail gblocks) single multi =
553 if isNullUFM gblocks then
554 case lastTail etail of
555 LastExit -> single etail
556 _ -> panic "bad single block"
558 case splitp_blocks is_exit gblocks of
559 Nothing -> panic "Can't find an exit block"
560 Just (gexit, gblocks) ->
561 let (gh, gl) = goto_end $ unzip gexit in
562 case gl of LastExit -> multi etail gh gblocks
563 _ -> panic "exit is not exit?!"
565 is_exit :: Block m l -> Bool
566 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
569 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
570 where eid = head_id head
571 splice_one_block tail' =
572 case ht_to_last head tail' of
573 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
574 _ -> panic "spliced LGraph without exit"
575 splice_many_blocks entry exit others =
576 (LGraph eid (insertBlock (zipht head entry) others), exit)
578 splice_head' head g =
579 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
580 where splice_one_block tail' =
581 case ht_to_last head tail' of
582 (head, LastExit) -> (emptyBlockEnv, head)
583 _ -> panic "spliced LGraph without exit"
584 splice_many_blocks entry exit others =
585 (insertBlock (zipht head entry) others, exit)
587 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
589 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
590 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
591 append_tails (ZLast LastExit) tail = tail
592 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
593 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
594 splice_many_blocks entry exit others =
595 Graph entry (insertBlock (zipht exit tail) others)
599 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
600 where splice_one_block tail' = -- return tail' .. tail
601 case ht_to_last (ZFirst (lg_entry g)) tail' of
603 case ht_to_block head' tail of
604 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
605 _ -> panic "entry in; garbage out"
606 _ -> panic "spliced single block without Exit"
607 splice_many_blocks entry exit others =
608 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
611 splice_head_only head g =
612 let FGraph eid gentry gblocks = entry g
614 ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
615 _ -> panic "entry not at start of block?!"
617 splice_head_only' head (Graph tail gblocks) =
618 let eblock = zipht head tail in
619 LGraph (blockId eblock) (insertBlock eblock gblocks)
624 translate txm txl (LGraph eid blocks) =
625 do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
626 return $ LGraph eid blocks'
629 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
630 txblock (Block id t) expanded =
631 do blocks' <- expanded
632 txtail (ZFirst id) t blocks'
633 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
634 -- tm (BlockEnv (Block m' l'))
635 txtail h (ZTail m t) blocks' =
637 let (g, h') = splice_head h m'
638 txtail h' t (plusUFM (lg_blocks g) blocks')
639 txtail h (ZLast (LastOther l)) blocks' =
641 return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
642 txtail h (ZLast LastExit) blocks' =
643 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
645 ----------------------------------------------------------------
647 ----------------------------------------------------------------
649 -- putting this code in PprCmmZ leads to circular imports :-(
651 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
654 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
657 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
660 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
663 instance (Outputable l) => Outputable (ZLast l) where
666 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
667 pprTail (ZTail m t) = ppr m $$ ppr t
668 pprTail (ZLast l) = ppr l
670 pprLast :: (Outputable l) => ZLast l -> SDoc
671 pprLast LastExit = text "<exit>"
672 pprLast (LastOther l) = ppr l
674 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
675 pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
677 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
678 pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}"
679 where blocks = postorder_dfs g
681 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
682 pprGraph (Graph tail blockenv) =
683 text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
684 where blocks = postorder_dfs_from blockenv tail