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_one_block, 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(..) )
44 import Outputable hiding (empty)
50 import Prelude hiding (zip, unzip, last)
52 -------------------------------------------------------------------------
53 -- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
54 -------------------------------------------------------------------------
57 This module defines datatypes used to represent control-flow graphs,
58 along with some functions for analyzing and splicing graphs.
59 Functions for building graphs are found in a separate module 'MkZipCfg'.
61 Every graph has a distinguished entry point. A graph has at least one
62 exit; most exits are instructions (or statements) like 'jump' or
63 'return', which transfer control to other procedures, but a graph may
64 have up to one 'fall through' exit. (A graph that represents an
65 entire Haskell or C-- procedure does not have a 'fall through' exit.)
67 A graph is a collection of basic blocks. A basic block begins with a
68 label (unique id; see Note [Unique BlockId]) which is followed by a
69 sequence of zero or more 'middle' nodes; the basic block ends with a
70 'last' node. Each 'middle' node is a single-entry, single-exit,
71 uninterruptible computation. A 'last' node is a single-entry,
72 multiple-exit computation. A last node may have zero or more successors,
73 which are identified by their unique ids.
75 A special case of last node is the ``default exit,'' which represents
76 'falling off the end' of the graph. Such a node is always represented by
77 the data constructor 'LastExit'. A graph may contain at most one
78 'LastExit' node, and a graph representing a full procedure should not
79 contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
80 graphs together, either during graph construction (see module 'MkZipCfg')
81 or during optimization (see module 'ZipDataflow0').
83 A graph is parameterized over the types of middle and last nodes. Each of
84 these types will typically be instantiated with a subset of C-- statements
85 (see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
86 implemented as of August 2007).
89 Note [Kinds of Graphs]
90 ~~~~~~~~~~~~~~~~~~~~~~
91 This module exposes three representations of graphs. In order of
92 increasing complexity, they are:
94 Graph m l The basic graph with its distinguished entry point
96 LGraph m l A graph with a *labelled* entry point
98 FGraph m l A labelled graph with the *focus* on a particular edge
100 There are three types because each type offers a slightly different
101 invariant or cost model.
103 * The distinguished entry of a Graph has no label. Because labels must be
104 unique, acquiring one requires a supply of Unique labels (BlockId's).
105 The primary advantage of the Graph representation is that we can build a
106 small Graph purely functionally, without needing a fresh BlockId or
107 Unique. For example, during optimization we can easily rewrite a single
108 middle node into a Graph containing a sequence of two middle nodes
109 followed by LastExit.
111 * In an LGraph, every basic block is labelled. The primary advantage of
112 this representation is its simplicity: each basic block can be treated
113 like any other. This representation is used for mapping, folding, and
114 translation, as well as layout.
116 Like any graph, an LGraph still has a distinguished entry point,
117 which you can discover using 'lg_entry'.
119 * An FGraph is an LGraph with the *focus* on one particular edge. The
120 primary advantage of this representation is that it provides
121 constant-time access to the nodes connected by that edge, and it also
122 allows constant-time, functional *replacement* of those nodes---in the
123 style of Huet's 'zipper'.
125 None of these representations is ideally suited to the incremental
126 construction of large graphs. A separate module, 'MkZipCfg', provides a
127 fourth representation that is asymptotically optimal for such construction.
131 --------------- Representation --------------------
133 -- | A basic block is a 'first' node, followed by zero or more 'middle'
134 -- nodes, followed by a 'last' node.
136 -- eventually this module should probably replace the original Cmm, but for
137 -- now we leave it to dynamic invariants what can be found where
140 = LastExit -- fall through; used for the block that has no last node
141 -- LastExit is a device used only for graphs under
142 -- construction, or framgments of graph under optimisation,
143 -- so we don't want to pollute the 'l' type parameter with it
146 --So that we don't have orphan instances, this goes here or in CmmExpr.
147 --At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
148 --but there's no need for non-Haskell98 instances for that.
149 instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
150 foldRegsUsed f z (LastOther l) = foldRegsUsed f z l
151 foldRegsUsed _f z LastExit = z
154 data ZHead m = ZFirst BlockId (Maybe Int)
156 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
157 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
158 -- ZTail is a sequence of middle nodes followed by a last node
160 -- | Blocks and flow graphs; see Note [Kinds of graphs]
161 -- In addition to its id, the block carries the number of bytes of stack space
162 -- used for incoming parameters on entry to the block.
163 data Block m l = Block BlockId (Maybe Int) (ZTail m l)
165 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
167 data LGraph m l = LGraph { lg_entry :: BlockId
168 , lg_argoffset :: Int -- space (bytes) for incoming args
169 , lg_blocks :: BlockEnv (Block m l)}
170 -- Invariant: lg_entry is in domain( lg_blocks )
172 -- | And now the zipper. The focus is between the head and tail.
173 -- We cannot ever focus on an inter-block edge.
174 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
175 data FGraph m l = FGraph { fg_entry :: BlockId
176 , fg_focus :: ZBlock m l
177 , fg_others :: BlockEnv (Block m l) }
178 -- Invariant: the block represented by 'fg_focus' is *not*
179 -- in the map 'fg_others'
181 ---- Utility functions ---
183 blockId :: Block m l -> BlockId
184 zip :: ZBlock m l -> Block m l
185 unzip :: Block m l -> ZBlock m l
187 last :: ZBlock m l -> ZLast l
188 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
190 tailOfLast :: l -> ZTail m l
192 -- | Take a head and tail and go to beginning or end. The asymmetry
193 -- in the types and names is a bit unfortunate, but 'Block m l' is
194 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
196 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
197 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
199 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
200 -- For a head, we have a head 'h' followed by a LGraph 'g'.
201 -- The entry node of 'g' gets joined to 'h', forming the entry into
202 -- the new LGraph. The exit of 'g' becomes the new head.
203 -- For both arguments and results, the order of values is the order of
204 -- control flow: before splicing, the head flows into the LGraph; after
205 -- splicing, the LGraph flows into the head.
206 -- Splicing a tail is the dual operation.
207 -- (In order to maintain the order-means-control-flow convention, the
208 -- orders are reversed.)
210 -- For example, assume
212 -- grph = (M, [M: <stuff>,
214 -- N: y:=x; LastExit])
215 -- tail = [return (y,x)]
217 -- Then splice_head head grph
218 -- = ((L, [L: x:=0; goto M,
223 -- Then splice_tail grph tail
225 -- , (???, [<blocks>,
226 -- N: y:=x; return (y,x)])
228 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
229 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
230 splice_tail :: Graph m l -> ZTail m l -> Graph m l
232 -- | We can also splice a single-entry, no-exit Graph into a head.
233 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
234 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
237 -- | A safe operation
239 -- | Conversion to and from the environment form is convenient. For
240 -- layout or dataflow, however, one will want to use 'postorder_dfs'
241 -- in order to get the blocks in an order that relates to the control
242 -- flow in the procedure.
243 of_block_list :: BlockId -> Int -> [Block m l] -> LGraph m l -- N log N
244 to_block_list :: LGraph m l -> [Block m l] -- N log N
246 -- | Conversion from LGraph to Graph
247 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
248 graphOfLGraph (LGraph eid _ blocks) = Graph (ZLast $ mkBranchNode eid) blocks
251 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
252 -- from the entry node. This list has the following property:
254 -- Say a "back reference" exists if one of a block's
255 -- control-flow successors precedes it in the output list
257 -- Then there are as few back references as possible
259 -- The output is suitable for use in
260 -- a forward dataflow problem. For a backward problem, simply reverse
261 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
262 -- one doesn't want to try and maintain both forward and backward
265 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
267 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
268 -- in layout order. The 'Maybe BlockId', if present, identifies the
269 -- block that will be the layout successor of the current block. This
270 -- may be useful to help an emitter omit the final 'goto' of a block
271 -- that flows directly to its layout successor.
273 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
274 -- = z <$> f (L1:B1) (Just L2)
275 -- <$> f (L2:B2) (Just L3)
276 -- <$> f (L3:B3) Nothing
277 -- where a <$> f = f a
279 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
281 -- | We can also fold over blocks in an unspecified order. The
282 -- 'ZipCfgExtras' module provides a monadic version, which we
283 -- haven't needed (else it would be here).
284 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
286 -- | Fold from first to last
288 (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a
290 map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
292 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
293 -- mapping includes the entry id!
295 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
296 mapM_blocks :: Monad mm
297 => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
299 -- | These translation functions are speculative. I hope eventually
300 -- they will be used in the native-code back ends ---NR
301 translate :: Monad tm =>
302 (m -> tm (LGraph m' l')) ->
303 (l -> tm (LGraph m' l')) ->
304 (LGraph m l -> tm (LGraph m' l'))
307 -- | It's possible that another form of translation would be more suitable:
308 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
311 ------------------- Last nodes
313 -- | We can't make a graph out of just any old 'last node' type. A last node
314 -- has to be able to find its successors, and we need to be able to create and
315 -- identify unconditional branches. We put these capabilities in a type class.
316 -- Moreover, the property of having successors is also shared by 'Block's and
317 -- 'ZTails', so it is useful to have that property in a type class of its own.
319 class HavingSuccessors b where
320 succs :: b -> [BlockId]
321 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
323 fold_succs add l z = foldr add z $ succs l
325 class HavingSuccessors l => LastNode l where
326 mkBranchNode :: BlockId -> l
327 isBranchNode :: l -> Bool
328 branchNodeTarget :: l -> BlockId -- panics if not branch node
329 -- ^ N.B. This interface seems to make for more congenial clients than a
330 -- single function of type 'l -> Maybe BlockId'
332 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
334 succs (LastOther l) = succs l
335 fold_succs _ LastExit z = z
336 fold_succs f (LastOther l) z = fold_succs f l z
338 instance LastNode l => LastNode (ZLast l) where
339 mkBranchNode id = LastOther $ mkBranchNode id
340 isBranchNode LastExit = False
341 isBranchNode (LastOther l) = isBranchNode l
342 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
343 branchNodeTarget (LastOther l) = branchNodeTarget l
345 instance LastNode l => HavingSuccessors (ZBlock m l) where
346 succs b = succs (last b)
348 instance LastNode l => HavingSuccessors (Block m l) where
349 succs b = succs (unzip b)
351 instance LastNode l => HavingSuccessors (ZTail m l) where
352 succs b = succs (lastTail b)
356 -- ================ IMPLEMENTATION ================--
358 ----- block manipulations
360 blockId (Block id _ _) = id
362 -- | Convert block between forms.
363 -- These functions are tail-recursive, so we can go as deep as we like
364 -- without fear of stack overflow.
366 ht_to_block head tail = case head of
367 ZFirst id off -> Block id off tail
368 ZHead h m -> ht_to_block h (ZTail m tail)
370 ht_to_last head (ZLast l) = (head, l)
371 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
373 zipht h t = ht_to_block h t
374 zip (ZBlock h t) = ht_to_block h t
375 goto_end (ZBlock h t) = ht_to_last h t
377 unzip (Block id off t) = ZBlock (ZFirst id off) t
379 head_id :: ZHead m -> BlockId
380 head_id (ZFirst id _) = id
381 head_id (ZHead h _) = head_id h
383 last (ZBlock _ t) = lastTail t
385 lastTail :: ZTail m l -> ZLast l
386 lastTail (ZLast l) = l
387 lastTail (ZTail _ t) = lastTail t
389 tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
392 ------------------ simple graph manipulations
394 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
395 focus id (LGraph entry _ blocks) =
396 case lookupBlockEnv blocks id of
397 Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
398 Nothing -> panic "asked for nonexistent block in flow graph"
400 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
401 entry g@(LGraph eid _ _) = focus eid g
403 -- | pull out a block satisfying the predicate, if any
404 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
405 Maybe (Block m l, BlockEnv (Block m l))
406 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
407 where scan b (yes, no) =
409 Nothing | p b -> (Just b, no)
410 | otherwise -> (yes, insertBlock b no)
411 Just _ -> (yes, insertBlock b no)
412 lift (Nothing, _) = Nothing
413 lift (Just b, bs) = Just (b, bs)
415 -- | 'insertBlock' should not be used to /replace/ an existing block
416 -- but only to insert a new one
417 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
419 ASSERT (isNothing $ lookupBlockEnv bs id)
420 extendBlockEnv bs id b
423 -- | Used in assertions; tells if a graph has exactly one exit
424 single_exit :: LGraph l m -> Bool
425 single_exit g = foldUFM check 0 (lg_blocks g) == 1
426 where check block count = case last (unzip block) of
427 LastExit -> count + (1 :: Int)
430 -- | Used in assertions; tells if a graph has exactly one exit
431 single_exitg :: Graph l m -> Bool
432 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
433 where add block count = count + exit_count (last (unzip block))
434 exit_count LastExit = 1 :: Int
437 ------------------ graph traversals
439 -- | This is the most important traversal over this data structure. It drops
440 -- unreachable code and puts blocks in an order that is good for solving forward
441 -- dataflow problems quickly. The reverse order is good for solving backward
442 -- dataflow problems quickly. The forward order is also reasonably good for
443 -- emitting instructions, except that it will not usually exploit Forrest
444 -- Baskett's trick of eliminating the unconditional branch from a loop. For
445 -- that you would need a more serious analysis, probably based on dominators, to
446 -- identify loop headers.
448 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
449 -- representation, when for most purposes the plain 'Graph' representation is
450 -- more mathematically elegant (but results in more complicated code).
452 -- Here's an easy way to go wrong! Consider
458 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
459 -- Better to geot [A,B,C,D]
462 postorder_dfs g@(LGraph _ _ blockenv) =
463 let FGraph id eblock _ = entry g in
464 zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
466 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
467 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
468 postorder_dfs_from_except blocks b visited =
469 vchildren (get_children b) (\acc _visited -> acc) [] visited
472 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
473 vnode block@(Block id _ _) cont acc visited =
474 if elemBlockSet id visited then
477 let cont' acc visited = cont (block:acc) visited in
478 vchildren (get_children block) cont' acc (extendBlockSet visited id)
479 vchildren bs cont acc visited =
480 let next children acc visited =
481 case children of [] -> cont acc visited
482 (b:bs) -> vnode b (next bs) acc visited
483 in next bs acc visited
484 get_children block = foldl add_id [] (succs block)
485 add_id rst id = case lookupBlockEnv blocks id of
490 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
491 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
495 -- | Slightly more complicated than the usual fold because we want to tell block
496 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
497 -- 'goto b2', the goto can be omitted.
499 fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z
500 where fold blocks z =
501 case blocks of [] -> z
503 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
504 nextlabel (Block id _ _) =
505 if id == eid then panic "entry as successor"
508 -- | The rest of the traversals are straightforward
510 map_blocks f (LGraph eid off blocks) = LGraph eid off (mapUFM f blocks)
512 map_nodes idm middle last (LGraph eid off blocks) =
513 LGraph (idm eid) off (mapUFM (map_one_block idm middle last) blocks)
515 map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
516 where tail (ZTail m t) = ZTail (middle m) (tail t)
517 tail (ZLast LastExit) = ZLast LastExit
518 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
521 mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off
523 foldUFM (\b mblocks -> do { blocks <- mblocks
525 ; return $ insertBlock b blocks })
526 (return emptyBlockEnv) blocks
528 fold_blocks f z (LGraph _ _ blocks) = foldUFM f z blocks
529 fold_fwd_block first middle last (Block id _ t) z = tail t (first id z)
530 where tail (ZTail m t) z = tail t (middle m z)
531 tail (ZLast l) z = last l z
533 of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks
534 to_block_list (LGraph _ _ blocks) = eltsUFM blocks
537 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
538 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
539 -- or it isn't. We use continuation-passing style.
541 prepare_for_splicing ::
542 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
544 prepare_for_splicing g single multi =
545 let FGraph _ gentry gblocks = entry g
546 ZBlock _ etail = gentry
547 in if isNullUFM gblocks then
549 LastExit -> single etail
550 _ -> panic "bad single block"
552 case splitp_blocks is_exit gblocks of
553 Nothing -> panic "Can't find an exit block"
554 Just (gexit, gblocks) ->
555 let (gh, gl) = goto_end $ unzip gexit in
556 case gl of LastExit -> multi etail gh gblocks
557 _ -> panic "exit is not exit?!"
559 prepare_for_splicing' ::
560 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
562 prepare_for_splicing' (Graph etail gblocks) single multi =
563 if isNullUFM gblocks then
564 case lastTail etail of
565 LastExit -> single etail
566 _ -> panic "bad single block"
568 case splitp_blocks is_exit gblocks of
569 Nothing -> panic "Can't find an exit block"
570 Just (gexit, gblocks) ->
571 let (gh, gl) = goto_end $ unzip gexit in
572 case gl of LastExit -> multi etail gh gblocks
573 _ -> panic "exit is not exit?!"
575 is_exit :: Block m l -> Bool
576 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
578 splice_head head g@(LGraph _ off _) =
579 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
580 where eid = head_id head
581 splice_one_block tail' =
582 case ht_to_last head tail' of
583 (head, LastExit) -> (LGraph eid off emptyBlockEnv, head)
584 _ -> panic "spliced LGraph without exit"
585 splice_many_blocks entry exit others =
586 (LGraph eid off (insertBlock (zipht head entry) others), exit)
588 splice_head' head g =
589 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
590 where splice_one_block tail' =
591 case ht_to_last head tail' of
592 (head, LastExit) -> (emptyBlockEnv, head)
593 _ -> panic "spliced LGraph without exit"
594 splice_many_blocks entry exit others =
595 (insertBlock (zipht head entry) others, exit)
597 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
599 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
600 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
601 append_tails (ZLast LastExit) tail = tail
602 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
603 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
604 splice_many_blocks entry exit others =
605 Graph entry (insertBlock (zipht exit tail) others)
609 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
610 where splice_one_block tail' = -- return tail' .. tail
611 case ht_to_last (ZFirst (lg_entry g)) tail' of
613 case ht_to_block head' tail of
614 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
615 _ -> panic "entry in; garbage out"
616 _ -> panic "spliced single block without Exit"
617 splice_many_blocks entry exit others =
618 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
621 splice_head_only head g =
622 let FGraph eid gentry gblocks = entry g
624 ZBlock (ZFirst _ _) tail ->
625 LGraph eid 0 (insertBlock (zipht head tail) gblocks)
626 _ -> panic "entry not at start of block?!"
628 splice_head_only' head (Graph tail gblocks) =
629 let eblock = zipht head tail in
630 LGraph (blockId eblock) 0 (insertBlock eblock gblocks)
631 -- the offset probably should never be used, but well, it's correct for this LGraph
636 translate txm txl (LGraph eid off blocks) =
637 do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
638 return $ LGraph eid off blocks'
641 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
642 txblock (Block id boff t) expanded =
643 do blocks' <- expanded
644 txtail (ZFirst id boff) t blocks'
645 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
646 -- tm (BlockEnv (Block m' l'))
647 txtail h (ZTail m t) blocks' =
649 let (g, h') = splice_head h m'
650 txtail h' t (plusUFM (lg_blocks g) blocks')
651 txtail h (ZLast (LastOther l)) blocks' =
653 return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
654 txtail h (ZLast LastExit) blocks' =
655 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
657 ----------------------------------------------------------------
659 ----------------------------------------------------------------
661 -- putting this code in PprCmmZ leads to circular imports :-(
663 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
666 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
669 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
672 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
675 instance (Outputable l) => Outputable (ZLast l) where
678 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
679 pprTail (ZTail m t) = ppr m $$ ppr t
680 pprTail (ZLast l) = ppr l
682 pprLast :: (Outputable l) => ZLast l -> SDoc
683 pprLast LastExit = text "<exit>"
684 pprLast (LastOther l) = ppr l
686 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
687 pprBlock (Block id args tail) = ppr id <> parens (ppr args) <> colon $$ ppr tail
689 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
690 pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$
691 nest 2 (vcat $ map ppr blocks) $$ text "}"
692 where blocks = postorder_dfs g
694 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
695 pprGraph (Graph tail blockenv) =
696 text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
697 where blocks = postorder_dfs_from blockenv tail