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 BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
40 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
41 import CmmExpr ( UserOfLocalRegs(..) ) --for an instance
43 import Outputable hiding (empty)
49 import Prelude hiding (zip, unzip, last)
51 -------------------------------------------------------------------------
52 -- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
53 -------------------------------------------------------------------------
56 This module defines datatypes used to represent control-flow graphs,
57 along with some functions for analyzing and splicing graphs.
58 Functions for building graphs are found in a separate module 'MkZipCfg'.
60 Every graph has a distinguished entry point. A graph has at least one
61 exit; most exits are instructions (or statements) like 'jump' or
62 'return', which transfer control to other procedures, but a graph may
63 have up to one 'fall through' exit. (A graph that represents an
64 entire Haskell or C-- procedure does not have a 'fall through' exit.)
66 A graph is a collection of basic blocks. A basic block begins with a
67 label (unique id; see Note [Unique BlockId]) which is followed by a
68 sequence of zero or more 'middle' nodes; the basic block ends with a
69 'last' node. Each 'middle' node is a single-entry, single-exit,
70 uninterruptible computation. A 'last' node is a single-entry,
71 multiple-exit computation. A last node may have zero or more successors,
72 which are identified by their unique ids.
74 A special case of last node is the ``default exit,'' which represents
75 'falling off the end' of the graph. Such a node is always represented by
76 the data constructor 'LastExit'. A graph may contain at most one
77 'LastExit' node, and a graph representing a full procedure should not
78 contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
79 graphs together, either during graph construction (see module 'MkZipCfg')
80 or during optimization (see module 'ZipDataflow0').
82 A graph is parameterized over the types of middle and last nodes. Each of
83 these types will typically be instantiated with a subset of C-- statements
84 (see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
85 implemented as of August 2007).
88 Note [Kinds of Graphs]
89 ~~~~~~~~~~~~~~~~~~~~~~
90 This module exposes three representations of graphs. In order of
91 increasing complexity, they are:
93 Graph m l The basic graph with its distinguished entry point
95 LGraph m l A graph with a *labelled* entry point
97 FGraph m l A labelled graph with the *focus* on a particular edge
99 There are three types because each type offers a slightly different
100 invariant or cost model.
102 * The distinguished entry of a Graph has no label. Because labels must be
103 unique, acquiring one requires a supply of Unique labels (BlockId's).
104 The primary advantage of the Graph representation is that we can build a
105 small Graph purely functionally, without needing a fresh BlockId or
106 Unique. For example, during optimization we can easily rewrite a single
107 middle node into a Graph containing a sequence of two middle nodes
108 followed by LastExit.
110 * In an LGraph, every basic block is labelled. The primary advantage of
111 this representation is its simplicity: each basic block can be treated
112 like any other. This representation is used for mapping, folding, and
113 translation, as well as layout.
115 Like any graph, an LGraph still has a distinguished entry point,
116 which you can discover using 'lg_entry'.
118 * An FGraph is an LGraph with the *focus* on one particular edge. The
119 primary advantage of this representation is that it provides
120 constant-time access to the nodes connected by that edge, and it also
121 allows constant-time, functional *replacement* of those nodes---in the
122 style of Huet's 'zipper'.
124 None of these representations is ideally suited to the incremental
125 construction of large graphs. A separate module, 'MkZipCfg', provides a
126 fourth representation that is asymptotically optimal for such construction.
130 --------------- Representation --------------------
132 -- | A basic block is a 'first' node, followed by zero or more 'middle'
133 -- nodes, followed by a 'last' node.
135 -- eventually this module should probably replace the original Cmm, but for
136 -- now we leave it to dynamic invariants what can be found where
139 = LastExit -- fall through; used for the block that has no last node
140 -- LastExit is a device used only for graphs under
141 -- construction, or framgments of graph under optimisation,
142 -- so we don't want to pollute the 'l' type parameter with it
145 --So that we don't have orphan instances, this goes here or in CmmExpr.
146 --At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
147 --but there's no need for non-Haskell98 instances for that.
148 instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
149 foldRegsUsed f z (LastOther l) = foldRegsUsed f z l
150 foldRegsUsed _f z LastExit = z
153 data ZHead m = ZFirst BlockId | ZHead (ZHead m) m
154 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
155 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
156 -- ZTail is a sequence of middle nodes followed by a last node
158 -- | Blocks and flow graphs; see Note [Kinds of graphs]
159 data Block m l = Block BlockId (ZTail m l)
161 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
163 data LGraph m l = LGraph { lg_entry :: BlockId
164 , lg_blocks :: BlockEnv (Block m l) }
165 -- Invariant: lg_entry is in domain( lg_blocks )
167 -- | And now the zipper. The focus is between the head and tail.
168 -- We cannot ever focus on an inter-block edge.
169 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
170 data FGraph m l = FGraph { fg_entry :: BlockId
171 , fg_focus :: ZBlock m l
172 , fg_others :: BlockEnv (Block m l) }
173 -- Invariant: the block represented by 'fg_focus' is *not*
174 -- in the map 'fg_others'
176 ---- Utility functions ---
178 blockId :: Block m l -> BlockId
179 zip :: ZBlock m l -> Block m l
180 unzip :: Block m l -> ZBlock m l
182 last :: ZBlock m l -> ZLast l
183 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
185 tailOfLast :: l -> ZTail m l
187 -- | Take a head and tail and go to beginning or end. The asymmetry
188 -- in the types and names is a bit unfortunate, but 'Block m l' is
189 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
191 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
192 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
194 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
195 -- For a head, we have a head 'h' followed by a LGraph 'g'.
196 -- The entry node of 'g' gets joined to 'h', forming the entry into
197 -- the new LGraph. The exit of 'g' becomes the new head.
198 -- For both arguments and results, the order of values is the order of
199 -- control flow: before splicing, the head flows into the LGraph; after
200 -- splicing, the LGraph flows into the head.
201 -- Splicing a tail is the dual operation.
202 -- (In order to maintain the order-means-control-flow convention, the
203 -- orders are reversed.)
205 -- For example, assume
207 -- grph = (M, [M: <stuff>,
209 -- N: y:=x; LastExit])
210 -- tail = [return (y,x)]
212 -- Then splice_head head grph
213 -- = ((L, [L: x:=0; goto M,
218 -- Then splice_tail grph tail
220 -- , (???, [<blocks>,
221 -- N: y:=x; return (y,x)])
223 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
224 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
225 splice_tail :: Graph m l -> ZTail m l -> Graph m l
227 -- | We can also splice a single-entry, no-exit Graph into a head.
228 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
229 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
232 -- | A safe operation
234 -- | Conversion to and from the environment form is convenient. For
235 -- layout or dataflow, however, one will want to use 'postorder_dfs'
236 -- in order to get the blocks in an order that relates to the control
237 -- flow in the procedure.
238 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
239 to_block_list :: LGraph m l -> [Block m l] -- N log N
241 -- | Conversion from LGraph to Graph
242 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
243 graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
246 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
247 -- from the entry node. This list has the following property:
249 -- Say a "back reference" exists if one of a block's
250 -- control-flow successors precedes it in the output list
252 -- Then there are as few back references as possible
254 -- The output is suitable for use in
255 -- a forward dataflow problem. For a backward problem, simply reverse
256 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
257 -- one doesn't want to try and maintain both forward and backward
260 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
262 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
263 -- in layout order. The 'Maybe BlockId', if present, identifies the
264 -- block that will be the layout successor of the current block. This
265 -- may be useful to help an emitter omit the final 'goto' of a block
266 -- that flows directly to its layout successor.
268 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
269 -- = z <$> f (L1:B1) (Just L2)
270 -- <$> f (L2:B2) (Just L3)
271 -- <$> f (L3:B3) Nothing
272 -- where a <$> f = f a
274 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
276 -- | We can also fold over blocks in an unspecified order. The
277 -- 'ZipCfgExtras' module provides a monadic version, which we
278 -- haven't needed (else it would be here).
279 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
281 -- | Fold from first to last
283 (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a
285 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
286 -- mapping includes the entry id!
288 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
289 mapM_blocks :: Monad mm
290 => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
292 -- | These translation functions are speculative. I hope eventually
293 -- they will be used in the native-code back ends ---NR
294 translate :: Monad tm =>
295 (m -> tm (LGraph m' l')) ->
296 (l -> tm (LGraph m' l')) ->
297 (LGraph m l -> tm (LGraph m' l'))
300 -- | It's possible that another form of translation would be more suitable:
301 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
304 ------------------- Last nodes
306 -- | We can't make a graph out of just any old 'last node' type. A last node
307 -- has to be able to find its successors, and we need to be able to create and
308 -- identify unconditional branches. We put these capabilities in a type class.
309 -- Moreover, the property of having successors is also shared by 'Block's and
310 -- 'ZTails', so it is useful to have that property in a type class of its own.
312 class HavingSuccessors b where
313 succs :: b -> [BlockId]
314 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
316 fold_succs add l z = foldr add z $ succs l
318 class HavingSuccessors l => LastNode l where
319 mkBranchNode :: BlockId -> l
320 isBranchNode :: l -> Bool
321 branchNodeTarget :: l -> BlockId -- panics if not branch node
322 -- ^ N.B. This interface seems to make for more congenial clients than a
323 -- single function of type 'l -> Maybe BlockId'
325 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
327 succs (LastOther l) = succs l
328 fold_succs _ LastExit z = z
329 fold_succs f (LastOther l) z = fold_succs f l z
331 instance LastNode l => LastNode (ZLast l) where
332 mkBranchNode id = LastOther $ mkBranchNode id
333 isBranchNode LastExit = False
334 isBranchNode (LastOther l) = isBranchNode l
335 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
336 branchNodeTarget (LastOther l) = branchNodeTarget l
338 instance LastNode l => HavingSuccessors (ZBlock m l) where
339 succs b = succs (last b)
341 instance LastNode l => HavingSuccessors (Block m l) where
342 succs b = succs (unzip b)
344 instance LastNode l => HavingSuccessors (ZTail m l) where
345 succs b = succs (lastTail b)
349 -- ================ IMPLEMENTATION ================--
351 ----- block manipulations
353 blockId (Block id _) = id
355 -- | Convert block between forms.
356 -- These functions are tail-recursive, so we can go as deep as we like
357 -- without fear of stack overflow.
359 ht_to_block head tail = case head of
360 ZFirst id -> Block id tail
361 ZHead h m -> ht_to_block h (ZTail m tail)
363 ht_to_last head (ZLast l) = (head, l)
364 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
366 zipht h t = ht_to_block h t
367 zip (ZBlock h t) = ht_to_block h t
368 goto_end (ZBlock h t) = ht_to_last h t
370 unzip (Block id t) = ZBlock (ZFirst id) t
372 head_id :: ZHead m -> BlockId
373 head_id (ZFirst id) = id
374 head_id (ZHead h _) = head_id h
376 last (ZBlock _ t) = lastTail t
378 lastTail :: ZTail m l -> ZLast l
379 lastTail (ZLast l) = l
380 lastTail (ZTail _ t) = lastTail t
382 tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client
385 ------------------ simple graph manipulations
387 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
388 focus id (LGraph entry blocks) =
389 case lookupBlockEnv blocks id of
390 Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
391 Nothing -> panic "asked for nonexistent block in flow graph"
393 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
394 entry g@(LGraph eid _) = focus eid g
396 -- | pull out a block satisfying the predicate, if any
397 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
398 Maybe (Block m l, BlockEnv (Block m l))
399 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
400 where scan b (yes, no) =
402 Nothing | p b -> (Just b, no)
403 | otherwise -> (yes, insertBlock b no)
404 Just _ -> (yes, insertBlock b no)
405 lift (Nothing, _) = Nothing
406 lift (Just b, bs) = Just (b, bs)
408 -- | 'insertBlock' should not be used to *replace* an existing block
409 -- but only to insert a new one
410 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
412 ASSERT (isNothing $ lookupBlockEnv bs id)
413 extendBlockEnv bs id b
416 -- | Used in assertions; tells if a graph has exactly one exit
417 single_exit :: LGraph l m -> Bool
418 single_exit g = foldUFM check 0 (lg_blocks g) == 1
419 where check block count = case last (unzip block) of
420 LastExit -> count + (1 :: Int)
423 -- | Used in assertions; tells if a graph has exactly one exit
424 single_exitg :: Graph l m -> Bool
425 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
426 where add block count = count + exit_count (last (unzip block))
427 exit_count LastExit = 1 :: Int
430 ------------------ graph traversals
432 -- | This is the most important traversal over this data structure. It drops
433 -- unreachable code and puts blocks in an order that is good for solving forward
434 -- dataflow problems quickly. The reverse order is good for solving backward
435 -- dataflow problems quickly. The forward order is also reasonably good for
436 -- emitting instructions, except that it will not usually exploit Forrest
437 -- Baskett's trick of eliminating the unconditional branch from a loop. For
438 -- that you would need a more serious analysis, probably based on dominators, to
439 -- identify loop headers.
441 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
442 -- representation, when for most purposes the plain 'Graph' representation is
443 -- more mathematically elegant (but results in more complicated code).
445 -- Here's an easy way to go wrong! Consider
449 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
450 -- Better to geot [A,B,C,D]
453 postorder_dfs g@(LGraph _ blockenv) =
454 let FGraph id eblock _ = entry g in
455 zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
457 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
458 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
459 postorder_dfs_from_except blocks b visited =
460 vchildren (get_children b) (\acc _visited -> acc) [] visited
463 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
464 vnode block@(Block id _) cont acc visited =
465 if elemBlockSet id visited then
468 let cont' acc visited = cont (block:acc) visited in
469 vchildren (get_children block) cont' acc (extendBlockSet visited id)
470 vchildren bs cont acc visited =
471 let next children acc visited =
472 case children of [] -> cont acc visited
473 (b:bs) -> vnode b (next bs) acc visited
474 in next bs acc visited
475 get_children block = foldl add_id [] (succs block)
476 add_id rst id = case lookupBlockEnv blocks id of
481 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
482 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
486 -- | Slightly more complicated than the usual fold because we want to tell block
487 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
488 -- 'goto b2', the goto can be omitted.
490 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
491 where fold blocks z =
492 case blocks of [] -> z
494 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
495 nextlabel (Block id _) =
496 if id == eid then panic "entry as successor"
499 -- | The rest of the traversals are straightforward
501 map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)
503 map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
504 where block (Block id t) = Block (idm id) (tail t)
505 tail (ZTail m t) = ZTail (middle m) (tail t)
506 tail (ZLast LastExit) = ZLast LastExit
507 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
510 mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
512 foldUFM (\b mblocks -> do { blocks <- mblocks
514 ; return $ insertBlock b blocks })
515 (return emptyBlockEnv) blocks
517 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
518 fold_fwd_block first middle last (Block id t) z = tail t (first id z)
519 where tail (ZTail m t) z = tail t (middle m z)
520 tail (ZLast l) z = last l z
522 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
523 to_block_list (LGraph _ blocks) = eltsUFM blocks
528 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
529 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
530 -- or it isn't. We use continuation-passing style.
532 prepare_for_splicing ::
533 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
535 prepare_for_splicing g single multi =
536 let FGraph _ gentry gblocks = entry g
537 ZBlock _ etail = gentry
538 in if isNullUFM gblocks then
540 LastExit -> single etail
541 _ -> panic "bad single block"
543 case splitp_blocks is_exit gblocks of
544 Nothing -> panic "Can't find an exit block"
545 Just (gexit, gblocks) ->
546 let (gh, gl) = goto_end $ unzip gexit in
547 case gl of LastExit -> multi etail gh gblocks
548 _ -> panic "exit is not exit?!"
550 prepare_for_splicing' ::
551 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
553 prepare_for_splicing' (Graph etail gblocks) single multi =
554 if isNullUFM gblocks then
555 case lastTail etail of
556 LastExit -> single etail
557 _ -> panic "bad single block"
559 case splitp_blocks is_exit gblocks of
560 Nothing -> panic "Can't find an exit block"
561 Just (gexit, gblocks) ->
562 let (gh, gl) = goto_end $ unzip gexit in
563 case gl of LastExit -> multi etail gh gblocks
564 _ -> panic "exit is not exit?!"
566 is_exit :: Block m l -> Bool
567 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
570 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
571 where eid = head_id head
572 splice_one_block tail' =
573 case ht_to_last head tail' of
574 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
575 _ -> panic "spliced LGraph without exit"
576 splice_many_blocks entry exit others =
577 (LGraph eid (insertBlock (zipht head entry) others), exit)
579 splice_head' head g =
580 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
581 where splice_one_block tail' =
582 case ht_to_last head tail' of
583 (head, LastExit) -> (emptyBlockEnv, head)
584 _ -> panic "spliced LGraph without exit"
585 splice_many_blocks entry exit others =
586 (insertBlock (zipht head entry) others, exit)
588 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
590 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
591 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
592 append_tails (ZLast LastExit) tail = tail
593 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
594 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
595 splice_many_blocks entry exit others =
596 Graph entry (insertBlock (zipht exit tail) others)
600 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
601 where splice_one_block tail' = -- return tail' .. tail
602 case ht_to_last (ZFirst (lg_entry g)) tail' of
604 case ht_to_block head' tail of
605 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
606 _ -> panic "entry in; garbage out"
607 _ -> panic "spliced single block without Exit"
608 splice_many_blocks entry exit others =
609 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
612 splice_head_only head g =
613 let FGraph eid gentry gblocks = entry g
615 ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
616 _ -> panic "entry not at start of block?!"
618 splice_head_only' head (Graph tail gblocks) =
619 let eblock = zipht head tail in
620 LGraph (blockId eblock) (insertBlock eblock gblocks)
625 translate txm txl (LGraph eid blocks) =
626 do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
627 return $ LGraph eid blocks'
630 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
631 txblock (Block id t) expanded =
632 do blocks' <- expanded
633 txtail (ZFirst id) t blocks'
634 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
635 -- tm (BlockEnv (Block m' l'))
636 txtail h (ZTail m t) blocks' =
638 let (g, h') = splice_head h m'
639 txtail h' t (plusUFM (lg_blocks g) blocks')
640 txtail h (ZLast (LastOther l)) blocks' =
642 return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
643 txtail h (ZLast LastExit) blocks' =
644 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
646 ----------------------------------------------------------------
648 ----------------------------------------------------------------
650 -- putting this code in PprCmmZ leads to circular imports :-(
652 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
655 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
658 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
661 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
664 instance (Outputable l) => Outputable (ZLast l) where
667 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
668 pprTail (ZTail m t) = ppr m $$ ppr t
669 pprTail (ZLast l) = ppr l
671 pprLast :: (Outputable l) => ZLast l -> SDoc
672 pprLast LastExit = text "<exit>"
673 pprLast (LastOther l) = ppr l
675 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
676 pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
678 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
679 pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}"
680 where blocks = postorder_dfs g
682 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
683 pprGraph (Graph tail blockenv) =
684 text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
685 where blocks = postorder_dfs_from blockenv tail