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, unitBlockSet, elemBlockSet, extendBlockSet
41 , delFromBlockEnv, foldBlockEnv', mapBlockEnv
42 , eltsBlockEnv, isNullBEnv, plusBlockEnv)
43 import CmmExpr ( UserOfLocalRegs(..) )
46 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 'ZipDataflow').
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
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]
162 data Block m l = Block { bid :: BlockId
163 , tail :: 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_blocks :: BlockEnv (Block m l)}
169 -- Invariant: lg_entry is in domain( lg_blocks )
171 -- | And now the zipper. The focus is between the head and tail.
172 -- We cannot ever focus on an inter-block edge.
173 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
174 data FGraph m l = FGraph { fg_entry :: BlockId
175 , fg_focus :: ZBlock m l
176 , fg_others :: BlockEnv (Block m l) }
177 -- Invariant: the block represented by 'fg_focus' is *not*
178 -- in the map 'fg_others'
180 ---- Utility functions ---
182 blockId :: Block m l -> BlockId
183 zip :: ZBlock m l -> Block m l
184 unzip :: Block m l -> ZBlock m l
186 last :: ZBlock m l -> ZLast l
187 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
189 tailOfLast :: l -> ZTail m l
191 -- | Take a head and tail and go to beginning or end. The asymmetry
192 -- in the types and names is a bit unfortunate, but 'Block m l' is
193 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
195 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
196 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
198 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
199 -- For a head, we have a head 'h' followed by a LGraph 'g'.
200 -- The entry node of 'g' gets joined to 'h', forming the entry into
201 -- the new LGraph. The exit of 'g' becomes the new head.
202 -- For both arguments and results, the order of values is the order of
203 -- control flow: before splicing, the head flows into the LGraph; after
204 -- splicing, the LGraph flows into the head.
205 -- Splicing a tail is the dual operation.
206 -- (In order to maintain the order-means-control-flow convention, the
207 -- orders are reversed.)
209 -- For example, assume
211 -- grph = (M, [M: <stuff>,
213 -- N: y:=x; LastExit])
214 -- tail = [return (y,x)]
216 -- Then splice_head head grph
217 -- = ((L, [L: x:=0; goto M,
222 -- Then splice_tail grph tail
224 -- , (???, [<blocks>,
225 -- N: y:=x; return (y,x)])
227 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
228 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
229 splice_tail :: Graph m l -> ZTail m l -> Graph m l
231 -- | We can also splice a single-entry, no-exit Graph into a head.
232 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
233 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
236 -- | A safe operation
238 -- | Conversion to and from the environment form is convenient. For
239 -- layout or dataflow, however, one will want to use 'postorder_dfs'
240 -- in order to get the blocks in an order that relates to the control
241 -- flow in the procedure.
242 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
243 to_block_list :: LGraph m l -> [Block m l] -- N log N
245 -- | Conversion from LGraph to Graph
246 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
247 graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
250 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
251 -- from the entry node. This list has the following property:
253 -- Say a "back reference" exists if one of a block's
254 -- control-flow successors precedes it in the output list
256 -- Then there are as few back references as possible
258 -- The output is suitable for use in
259 -- a forward dataflow problem. For a backward problem, simply reverse
260 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
261 -- one doesn't want to try and maintain both forward and backward
264 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
266 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
267 -- in layout order. The 'Maybe BlockId', if present, identifies the
268 -- block that will be the layout successor of the current block. This
269 -- may be useful to help an emitter omit the final 'goto' of a block
270 -- that flows directly to its layout successor.
272 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
273 -- = z <$> f (L1:B1) (Just L2)
274 -- <$> f (L2:B2) (Just L3)
275 -- <$> f (L3:B3) Nothing
276 -- where a <$> f = f a
278 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
280 -- | We can also fold over blocks in an unspecified order. The
281 -- 'ZipCfgExtras' module provides a monadic version, which we
282 -- haven't needed (else it would be here).
283 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
285 -- | Fold from first to last
286 fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) ->
287 (ZLast l -> a -> a) -> Block m l -> a -> a
289 map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
291 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
292 -- mapping includes the entry id!
294 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
295 mapM_blocks :: Monad mm
296 => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
298 -- | These translation functions are speculative. I hope eventually
299 -- they will be used in the native-code back ends ---NR
300 translate :: Monad tm =>
301 (m -> tm (LGraph m' l')) ->
302 (l -> tm (LGraph m' l')) ->
303 (LGraph m l -> tm (LGraph m' l'))
306 -- | It's possible that another form of translation would be more suitable:
307 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
310 ------------------- Last nodes
312 -- | We can't make a graph out of just any old 'last node' type. A last node
313 -- has to be able to find its successors, and we need to be able to create and
314 -- identify unconditional branches. We put these capabilities in a type class.
315 -- Moreover, the property of having successors is also shared by 'Block's and
316 -- 'ZTails', so it is useful to have that property in a type class of its own.
318 class HavingSuccessors b where
319 succs :: b -> [BlockId]
320 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
322 fold_succs add l z = foldr add z $ succs l
324 class HavingSuccessors l => LastNode l where
325 mkBranchNode :: BlockId -> l
326 isBranchNode :: l -> Bool
327 branchNodeTarget :: l -> BlockId -- panics if not branch node
328 -- ^ N.B. This interface seems to make for more congenial clients than a
329 -- single function of type 'l -> Maybe BlockId'
331 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
333 succs (LastOther l) = succs l
334 fold_succs _ LastExit z = z
335 fold_succs f (LastOther l) z = fold_succs f l z
337 instance LastNode l => LastNode (ZLast l) where
338 mkBranchNode id = LastOther $ mkBranchNode id
339 isBranchNode LastExit = False
340 isBranchNode (LastOther l) = isBranchNode l
341 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
342 branchNodeTarget (LastOther l) = branchNodeTarget l
344 instance LastNode l => HavingSuccessors (ZBlock m l) where
345 succs b = succs (last b)
347 instance LastNode l => HavingSuccessors (Block m l) where
348 succs b = succs (unzip b)
350 instance LastNode l => HavingSuccessors (ZTail m l) where
351 succs b = succs (lastTail b)
355 -- ================ IMPLEMENTATION ================--
357 ----- block manipulations
359 blockId (Block id _) = id
361 -- | Convert block between forms.
362 -- These functions are tail-recursive, so we can go as deep as we like
363 -- without fear of stack overflow.
365 ht_to_block head tail = case head of
366 ZFirst id -> Block id tail
367 ZHead h m -> ht_to_block h (ZTail m tail)
369 ht_to_last head (ZLast l) = (head, l)
370 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
372 zipht h t = ht_to_block h t
373 zip (ZBlock h t) = ht_to_block h t
374 goto_end (ZBlock h t) = ht_to_last h t
376 unzip (Block id t) = ZBlock (ZFirst id) t
378 head_id :: ZHead m -> BlockId
379 head_id (ZFirst id) = id
380 head_id (ZHead h _) = head_id h
382 last (ZBlock _ t) = lastTail t
384 lastTail :: ZTail m l -> ZLast l
385 lastTail (ZLast l) = l
386 lastTail (ZTail _ t) = lastTail t
388 tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
391 ------------------ simple graph manipulations
393 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
394 focus id (LGraph entry blocks) =
395 case lookupBlockEnv blocks id of
396 Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
397 Nothing -> panic "asked for nonexistent block in flow graph"
399 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
400 entry g@(LGraph eid _) = focus eid g
402 -- | pull out a block satisfying the predicate, if any
403 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
404 Maybe (Block m l, BlockEnv (Block m l))
405 splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks
406 where scan b (yes, no) =
408 Nothing | p b -> (Just b, no)
409 | otherwise -> (yes, insertBlock b no)
410 Just _ -> (yes, insertBlock b no)
411 lift (Nothing, _) = Nothing
412 lift (Just b, bs) = Just (b, bs)
414 -- | 'insertBlock' should not be used to /replace/ an existing block
415 -- but only to insert a new one
416 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
418 ASSERT (isNothing $ lookupBlockEnv bs id)
419 extendBlockEnv bs id b
422 -- | Used in assertions; tells if a graph has exactly one exit
423 single_exit :: LGraph l m -> Bool
424 single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1
425 where check block count = case last (unzip block) of
426 LastExit -> count + (1 :: Int)
429 -- | Used in assertions; tells if a graph has exactly one exit
430 single_exitg :: Graph l m -> Bool
431 single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1
432 where add block count = count + exit_count (last (unzip block))
433 exit_count LastExit = 1 :: Int
436 ------------------ graph traversals
438 -- | This is the most important traversal over this data structure. It drops
439 -- unreachable code and puts blocks in an order that is good for solving forward
440 -- dataflow problems quickly. The reverse order is good for solving backward
441 -- dataflow problems quickly. The forward order is also reasonably good for
442 -- emitting instructions, except that it will not usually exploit Forrest
443 -- Baskett's trick of eliminating the unconditional branch from a loop. For
444 -- that you would need a more serious analysis, probably based on dominators, to
445 -- identify loop headers.
447 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
448 -- representation, when for most purposes the plain 'Graph' representation is
449 -- more mathematically elegant (but results in more complicated code).
451 -- Here's an easy way to go wrong! Consider
457 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
458 -- Better to get [A,B,C,D]
461 postorder_dfs g@(LGraph _ blockenv) =
462 let FGraph id eblock _ = entry g in
463 zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
465 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
466 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
467 postorder_dfs_from_except blocks b visited =
468 vchildren (get_children b) (\acc _visited -> acc) [] visited
471 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
472 vnode block@(Block id _) cont acc visited =
473 if elemBlockSet id visited then
476 let cont' acc visited = cont (block:acc) visited in
477 vchildren (get_children block) cont' acc (extendBlockSet visited id)
478 vchildren bs cont acc visited =
479 let next children acc visited =
480 case children of [] -> cont acc visited
481 (b:bs) -> vnode b (next bs) acc visited
482 in next bs acc visited
483 get_children block = foldl add_id [] (succs block)
484 add_id rst id = case lookupBlockEnv blocks id of
489 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
490 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
494 -- | Slightly more complicated than the usual fold because we want to tell block
495 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
496 -- 'goto b2', the goto can be omitted.
498 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
499 where fold blocks z =
500 case blocks of [] -> z
502 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
503 nextlabel (Block id _) =
504 if id == eid then panic "entry as successor"
507 -- | The rest of the traversals are straightforward
509 map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks)
511 map_nodes idm middle last (LGraph eid blocks) =
512 LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks)
514 map_one_block idm middle last (Block id t) = Block (idm id) (tail t)
515 where tail (ZTail m t) = ZTail (middle m) (tail t)
516 tail (ZLast LastExit) = ZLast LastExit
517 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
520 mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
522 foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
524 ; return $ insertBlock b blocks })
525 (return emptyBlockEnv) blocks
527 fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks
528 fold_fwd_block first middle last (Block id t) z = tail t (first id z)
529 where tail (ZTail m t) z = tail t (middle m z)
530 tail (ZLast l) z = last l z
532 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
533 to_block_list (LGraph _ blocks) = eltsBlockEnv blocks
536 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
537 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
538 -- or it isn't. We use continuation-passing style.
540 prepare_for_splicing ::
541 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
543 prepare_for_splicing g single multi =
544 let FGraph _ gentry gblocks = entry g
545 ZBlock _ etail = gentry
546 in if isNullBEnv gblocks then
548 LastExit -> single etail
549 _ -> panic "bad single block"
551 case splitp_blocks is_exit gblocks of
552 Nothing -> panic "Can't find an exit block"
553 Just (gexit, gblocks) ->
554 let (gh, gl) = goto_end $ unzip gexit in
555 case gl of LastExit -> multi etail gh gblocks
556 _ -> panic "exit is not exit?!"
558 prepare_for_splicing' ::
559 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
561 prepare_for_splicing' (Graph etail gblocks) single multi =
562 if isNullBEnv gblocks then
563 case lastTail etail of
564 LastExit -> single etail
565 _ -> panic "bad single block"
567 case splitp_blocks is_exit gblocks of
568 Nothing -> panic "Can't find an exit block"
569 Just (gexit, gblocks) ->
570 let (gh, gl) = goto_end $ unzip gexit in
571 case gl of LastExit -> multi etail gh gblocks
572 _ -> panic "exit is not exit?!"
574 is_exit :: Block m l -> Bool
575 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
577 splice_head head g@(LGraph _ _) =
578 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
579 where eid = head_id head
580 splice_one_block tail' =
581 case ht_to_last head tail' of
582 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
583 _ -> panic "spliced LGraph without exit"
584 splice_many_blocks entry exit others =
585 (LGraph eid (insertBlock (zipht head entry) others), exit)
587 splice_head' head g =
588 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
589 where splice_one_block tail' =
590 case ht_to_last head tail' of
591 (head, LastExit) -> (emptyBlockEnv, head)
592 _ -> panic "spliced LGraph without exit"
593 splice_many_blocks entry exit others =
594 (insertBlock (zipht head entry) others, exit)
596 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
598 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
599 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
600 append_tails (ZLast LastExit) tail = tail
601 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
602 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
603 splice_many_blocks entry exit others =
604 Graph entry (insertBlock (zipht exit tail) others)
608 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
609 where splice_one_block tail' = -- return tail' .. tail
610 case ht_to_last (ZFirst (lg_entry g)) tail' of
612 case ht_to_block head' tail of
613 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
614 _ -> panic "entry in; garbage out"
615 _ -> panic "spliced single block without Exit"
616 splice_many_blocks entry exit others =
617 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
620 splice_head_only head g =
621 let FGraph eid gentry gblocks = entry g
623 ZBlock (ZFirst _) tail ->
624 LGraph eid (insertBlock (zipht head tail) gblocks)
625 _ -> panic "entry not at start of block?!"
627 splice_head_only' head (Graph tail gblocks) =
628 let eblock = zipht head tail in
629 LGraph (blockId eblock) (insertBlock eblock gblocks)
630 -- the offset probably should never be used, but well, it's correct for this LGraph
635 translate txm txl (LGraph eid blocks) =
636 do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
637 return $ LGraph eid blocks'
640 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
641 txblock (Block id t) expanded =
642 do blocks' <- expanded
643 txtail (ZFirst id) t blocks'
644 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
645 -- tm (BlockEnv (Block m' l'))
646 txtail h (ZTail m t) blocks' =
648 let (g, h') = splice_head h m'
649 txtail h' t (plusBlockEnv (lg_blocks g) blocks')
650 txtail h (ZLast (LastOther l)) blocks' =
652 return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
653 txtail h (ZLast LastExit) blocks' =
654 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
656 ----------------------------------------------------------------
658 ----------------------------------------------------------------
660 -- putting this code in PprCmmZ leads to circular imports :-(
662 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
665 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
668 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
671 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
674 instance (Outputable l) => Outputable (ZLast l) where
677 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
678 pprTail (ZTail m t) = ppr m $$ ppr t
679 pprTail (ZLast l) = ppr l
681 pprLast :: (Outputable l) => ZLast l -> SDoc
682 pprLast LastExit = text "<exit>"
683 pprLast (LastOther l) = ppr l
685 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
686 pprBlock (Block id tail) =
688 $$ (nest 3 (ppr tail))
690 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
691 pprLgraph g = text "{" <> text "offset" $$
692 nest 2 (vcat $ map ppr blocks) $$ text "}"
693 where blocks = postorder_dfs g
695 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
696 pprGraph (Graph tail blockenv) =
697 text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
698 where blocks = postorder_dfs_from blockenv tail