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)
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 'ZipDataflow').
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
155 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
156 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
157 -- ZTail is a sequence of middle nodes followed by a last node
159 -- | Blocks and flow graphs; see Note [Kinds of graphs]
161 data Block m l = Block { bid :: BlockId
162 , tail :: ZTail m l }
164 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
166 data LGraph m l = LGraph { lg_entry :: BlockId
167 , lg_blocks :: BlockEnv (Block m l)}
168 -- Invariant: lg_entry is in domain( lg_blocks )
170 -- | And now the zipper. The focus is between the head and tail.
171 -- We cannot ever focus on an inter-block edge.
172 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
173 data FGraph m l = FGraph { fg_entry :: BlockId
174 , fg_focus :: ZBlock m l
175 , fg_others :: BlockEnv (Block m l) }
176 -- Invariant: the block represented by 'fg_focus' is *not*
177 -- in the map 'fg_others'
179 ---- Utility functions ---
181 blockId :: Block m l -> BlockId
182 zip :: ZBlock m l -> Block m l
183 unzip :: Block m l -> ZBlock m l
185 last :: ZBlock m l -> ZLast l
186 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
188 tailOfLast :: l -> ZTail m l
190 -- | Take a head and tail and go to beginning or end. The asymmetry
191 -- in the types and names is a bit unfortunate, but 'Block m l' is
192 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
194 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
195 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
197 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
198 -- For a head, we have a head 'h' followed by a LGraph 'g'.
199 -- The entry node of 'g' gets joined to 'h', forming the entry into
200 -- the new LGraph. The exit of 'g' becomes the new head.
201 -- For both arguments and results, the order of values is the order of
202 -- control flow: before splicing, the head flows into the LGraph; after
203 -- splicing, the LGraph flows into the head.
204 -- Splicing a tail is the dual operation.
205 -- (In order to maintain the order-means-control-flow convention, the
206 -- orders are reversed.)
208 -- For example, assume
210 -- grph = (M, [M: <stuff>,
212 -- N: y:=x; LastExit])
213 -- tail = [return (y,x)]
215 -- Then splice_head head grph
216 -- = ((L, [L: x:=0; goto M,
221 -- Then splice_tail grph tail
223 -- , (???, [<blocks>,
224 -- N: y:=x; return (y,x)])
226 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
227 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
228 splice_tail :: Graph m l -> ZTail m l -> Graph m l
230 -- | We can also splice a single-entry, no-exit Graph into a head.
231 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
232 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
235 -- | A safe operation
237 -- | Conversion to and from the environment form is convenient. For
238 -- layout or dataflow, however, one will want to use 'postorder_dfs'
239 -- in order to get the blocks in an order that relates to the control
240 -- flow in the procedure.
241 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
242 to_block_list :: LGraph m l -> [Block m l] -- N log N
244 -- | Conversion from LGraph to Graph
245 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
246 graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
249 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
250 -- from the entry node. This list has the following property:
252 -- Say a "back reference" exists if one of a block's
253 -- control-flow successors precedes it in the output list
255 -- Then there are as few back references as possible
257 -- The output is suitable for use in
258 -- a forward dataflow problem. For a backward problem, simply reverse
259 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
260 -- one doesn't want to try and maintain both forward and backward
263 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
265 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
266 -- in layout order. The 'Maybe BlockId', if present, identifies the
267 -- block that will be the layout successor of the current block. This
268 -- may be useful to help an emitter omit the final 'goto' of a block
269 -- that flows directly to its layout successor.
271 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
272 -- = z <$> f (L1:B1) (Just L2)
273 -- <$> f (L2:B2) (Just L3)
274 -- <$> f (L3:B3) Nothing
275 -- where a <$> f = f a
277 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
279 -- | We can also fold over blocks in an unspecified order. The
280 -- 'ZipCfgExtras' module provides a monadic version, which we
281 -- haven't needed (else it would be here).
282 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
284 -- | Fold from first to last
285 fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) ->
286 (ZLast l -> a -> a) -> Block m l -> a -> a
288 map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
290 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
291 -- mapping includes the entry id!
293 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
294 mapM_blocks :: Monad mm
295 => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
297 -- | These translation functions are speculative. I hope eventually
298 -- they will be used in the native-code back ends ---NR
299 translate :: Monad tm =>
300 (m -> tm (LGraph m' l')) ->
301 (l -> tm (LGraph m' l')) ->
302 (LGraph m l -> tm (LGraph m' l'))
305 -- | It's possible that another form of translation would be more suitable:
306 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
309 ------------------- Last nodes
311 -- | We can't make a graph out of just any old 'last node' type. A last node
312 -- has to be able to find its successors, and we need to be able to create and
313 -- identify unconditional branches. We put these capabilities in a type class.
314 -- Moreover, the property of having successors is also shared by 'Block's and
315 -- 'ZTails', so it is useful to have that property in a type class of its own.
317 class HavingSuccessors b where
318 succs :: b -> [BlockId]
319 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
321 fold_succs add l z = foldr add z $ succs l
323 class HavingSuccessors l => LastNode l where
324 mkBranchNode :: BlockId -> l
325 isBranchNode :: l -> Bool
326 branchNodeTarget :: l -> BlockId -- panics if not branch node
327 -- ^ N.B. This interface seems to make for more congenial clients than a
328 -- single function of type 'l -> Maybe BlockId'
330 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
332 succs (LastOther l) = succs l
333 fold_succs _ LastExit z = z
334 fold_succs f (LastOther l) z = fold_succs f l z
336 instance LastNode l => LastNode (ZLast l) where
337 mkBranchNode id = LastOther $ mkBranchNode id
338 isBranchNode LastExit = False
339 isBranchNode (LastOther l) = isBranchNode l
340 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
341 branchNodeTarget (LastOther l) = branchNodeTarget l
343 instance LastNode l => HavingSuccessors (ZBlock m l) where
344 succs b = succs (last b)
346 instance LastNode l => HavingSuccessors (Block m l) where
347 succs b = succs (unzip b)
349 instance LastNode l => HavingSuccessors (ZTail m l) where
350 succs b = succs (lastTail b)
354 -- ================ IMPLEMENTATION ================--
356 ----- block manipulations
358 blockId (Block id _) = id
360 -- | Convert block between forms.
361 -- These functions are tail-recursive, so we can go as deep as we like
362 -- without fear of stack overflow.
364 ht_to_block head tail = case head of
365 ZFirst id -> Block id tail
366 ZHead h m -> ht_to_block h (ZTail m tail)
368 ht_to_last head (ZLast l) = (head, l)
369 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
371 zipht h t = ht_to_block h t
372 zip (ZBlock h t) = ht_to_block h t
373 goto_end (ZBlock h t) = ht_to_last h t
375 unzip (Block id t) = ZBlock (ZFirst id) t
377 head_id :: ZHead m -> BlockId
378 head_id (ZFirst id) = id
379 head_id (ZHead h _) = head_id h
381 last (ZBlock _ t) = lastTail t
383 lastTail :: ZTail m l -> ZLast l
384 lastTail (ZLast l) = l
385 lastTail (ZTail _ t) = lastTail t
387 tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
390 ------------------ simple graph manipulations
392 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
393 focus id (LGraph entry blocks) =
394 case lookupBlockEnv blocks id of
395 Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
396 Nothing -> panic "asked for nonexistent block in flow graph"
398 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
399 entry g@(LGraph eid _) = focus eid g
401 -- | pull out a block satisfying the predicate, if any
402 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
403 Maybe (Block m l, BlockEnv (Block m l))
404 splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks
405 where scan b (yes, no) =
407 Nothing | p b -> (Just b, no)
408 | otherwise -> (yes, insertBlock b no)
409 Just _ -> (yes, insertBlock b no)
410 lift (Nothing, _) = Nothing
411 lift (Just b, bs) = Just (b, bs)
413 -- | 'insertBlock' should not be used to /replace/ an existing block
414 -- but only to insert a new one
415 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
417 ASSERT (isNothing $ lookupBlockEnv bs id)
418 extendBlockEnv bs id b
421 -- | Used in assertions; tells if a graph has exactly one exit
422 single_exit :: LGraph l m -> Bool
423 single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1
424 where check block count = case last (unzip block) of
425 LastExit -> count + (1 :: Int)
428 -- | Used in assertions; tells if a graph has exactly one exit
429 single_exitg :: Graph l m -> Bool
430 single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1
431 where add block count = count + exit_count (last (unzip block))
432 exit_count LastExit = 1 :: Int
435 ------------------ graph traversals
437 -- | This is the most important traversal over this data structure. It drops
438 -- unreachable code and puts blocks in an order that is good for solving forward
439 -- dataflow problems quickly. The reverse order is good for solving backward
440 -- dataflow problems quickly. The forward order is also reasonably good for
441 -- emitting instructions, except that it will not usually exploit Forrest
442 -- Baskett's trick of eliminating the unconditional branch from a loop. For
443 -- that you would need a more serious analysis, probably based on dominators, to
444 -- identify loop headers.
446 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
447 -- representation, when for most purposes the plain 'Graph' representation is
448 -- more mathematically elegant (but results in more complicated code).
450 -- Here's an easy way to go wrong! Consider
456 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
457 -- Better to get [A,B,C,D]
460 postorder_dfs g@(LGraph _ blockenv) =
461 let FGraph id eblock _ = entry g in
462 zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
464 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
465 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
466 postorder_dfs_from_except blocks b visited =
467 vchildren (get_children b) (\acc _visited -> acc) [] visited
470 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
471 vnode block@(Block id _) cont acc visited =
472 if elemBlockSet id visited then
475 let cont' acc visited = cont (block:acc) visited in
476 vchildren (get_children block) cont' acc (extendBlockSet visited id)
477 vchildren bs cont acc visited =
478 let next children acc visited =
479 case children of [] -> cont acc visited
480 (b:bs) -> vnode b (next bs) acc visited
481 in next bs acc visited
482 get_children block = foldl add_id [] (succs block)
483 add_id rst id = case lookupBlockEnv blocks id of
488 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
489 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
493 -- | Slightly more complicated than the usual fold because we want to tell block
494 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
495 -- 'goto b2', the goto can be omitted.
497 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
498 where fold blocks z =
499 case blocks of [] -> z
501 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
502 nextlabel (Block id _) =
503 if id == eid then panic "entry as successor"
506 -- | The rest of the traversals are straightforward
508 map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks)
510 map_nodes idm middle last (LGraph eid blocks) =
511 LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks)
513 map_one_block idm middle last (Block id t) = Block (idm id) (tail t)
514 where tail (ZTail m t) = ZTail (middle m) (tail t)
515 tail (ZLast LastExit) = ZLast LastExit
516 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
519 mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
521 foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
523 ; return $ insertBlock b blocks })
524 (return emptyBlockEnv) blocks
526 fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks
527 fold_fwd_block first middle last (Block id t) z = tail t (first id z)
528 where tail (ZTail m t) z = tail t (middle m z)
529 tail (ZLast l) z = last l z
531 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
532 to_block_list (LGraph _ blocks) = eltsBlockEnv blocks
535 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
536 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
537 -- or it isn't. We use continuation-passing style.
539 prepare_for_splicing ::
540 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
542 prepare_for_splicing g single multi =
543 let FGraph _ gentry gblocks = entry g
544 ZBlock _ etail = gentry
545 in if isNullBEnv gblocks then
547 LastExit -> single etail
548 _ -> panic "bad single block"
550 case splitp_blocks is_exit gblocks of
551 Nothing -> panic "Can't find an exit block"
552 Just (gexit, gblocks) ->
553 let (gh, gl) = goto_end $ unzip gexit in
554 case gl of LastExit -> multi etail gh gblocks
555 _ -> panic "exit is not exit?!"
557 prepare_for_splicing' ::
558 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
560 prepare_for_splicing' (Graph etail gblocks) single multi =
561 if isNullBEnv gblocks then
562 case lastTail etail of
563 LastExit -> single etail
564 _ -> panic "bad single block"
566 case splitp_blocks is_exit gblocks of
567 Nothing -> panic "Can't find an exit block"
568 Just (gexit, gblocks) ->
569 let (gh, gl) = goto_end $ unzip gexit in
570 case gl of LastExit -> multi etail gh gblocks
571 _ -> panic "exit is not exit?!"
573 is_exit :: Block m l -> Bool
574 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
576 splice_head head g@(LGraph _ _) =
577 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
578 where eid = head_id head
579 splice_one_block tail' =
580 case ht_to_last head tail' of
581 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
582 _ -> panic "spliced LGraph without exit"
583 splice_many_blocks entry exit others =
584 (LGraph eid (insertBlock (zipht head entry) others), exit)
586 splice_head' head g =
587 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
588 where splice_one_block tail' =
589 case ht_to_last head tail' of
590 (head, LastExit) -> (emptyBlockEnv, head)
591 _ -> panic "spliced LGraph without exit"
592 splice_many_blocks entry exit others =
593 (insertBlock (zipht head entry) others, exit)
595 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
597 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
598 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
599 append_tails (ZLast LastExit) tail = tail
600 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
601 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
602 splice_many_blocks entry exit others =
603 Graph entry (insertBlock (zipht exit tail) others)
607 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
608 where splice_one_block tail' = -- return tail' .. tail
609 case ht_to_last (ZFirst (lg_entry g)) tail' of
611 case ht_to_block head' tail of
612 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
613 _ -> panic "entry in; garbage out"
614 _ -> panic "spliced single block without Exit"
615 splice_many_blocks entry exit others =
616 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
619 splice_head_only head g =
620 let FGraph eid gentry gblocks = entry g
622 ZBlock (ZFirst _) tail ->
623 LGraph eid (insertBlock (zipht head tail) gblocks)
624 _ -> panic "entry not at start of block?!"
626 splice_head_only' head (Graph tail gblocks) =
627 let eblock = zipht head tail in
628 LGraph (blockId eblock) (insertBlock eblock gblocks)
629 -- the offset probably should never be used, but well, it's correct for this LGraph
634 translate txm txl (LGraph eid blocks) =
635 do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
636 return $ LGraph eid blocks'
639 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
640 txblock (Block id t) expanded =
641 do blocks' <- expanded
642 txtail (ZFirst id) t blocks'
643 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
644 -- tm (BlockEnv (Block m' l'))
645 txtail h (ZTail m t) blocks' =
647 let (g, h') = splice_head h m'
648 txtail h' t (plusBlockEnv (lg_blocks g) blocks')
649 txtail h (ZLast (LastOther l)) blocks' =
651 return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
652 txtail h (ZLast LastExit) blocks' =
653 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
655 ----------------------------------------------------------------
657 ----------------------------------------------------------------
659 -- putting this code in PprCmmZ leads to circular imports :-(
661 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
664 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
667 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
670 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
673 instance (Outputable l) => Outputable (ZLast l) where
676 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
677 pprTail (ZTail m t) = ppr m $$ ppr t
678 pprTail (ZLast l) = ppr l
680 pprLast :: (Outputable l) => ZLast l -> SDoc
681 pprLast LastExit = text "<exit>"
682 pprLast (LastOther l) = ppr l
684 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
685 pprBlock (Block id tail) =
687 $$ (nest 3 (ppr tail))
689 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
690 pprLgraph g = text "{" <> text "offset" $$
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