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 :: forall m b l. (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
469 vnode :: Block m l -> ([Block m l] -> BlockSet -> a)
470 -> [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)
478 vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a)
479 -> [Block m l] -> BlockSet -> a
480 vchildren bs cont acc visited =
481 let next children acc visited =
482 case children of [] -> cont acc visited
483 (b:bs) -> vnode b (next bs) acc visited
484 in next bs acc visited
486 get_children :: HavingSuccessors c => c -> [Block m l]
487 get_children block = foldl add_id [] (succs block)
489 add_id :: [Block m l] -> BlockId -> [Block m l]
490 add_id rst id = case lookupBlockEnv blocks id of
495 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
496 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
500 -- | Slightly more complicated than the usual fold because we want to tell block
501 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
502 -- 'goto b2', the goto can be omitted.
504 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
505 where fold blocks z =
506 case blocks of [] -> z
508 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
509 nextlabel (Block id _) =
510 if id == eid then panic "entry as successor"
513 -- | The rest of the traversals are straightforward
515 map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks)
517 map_nodes idm middle last (LGraph eid blocks) =
518 LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks)
520 map_one_block idm middle last (Block id t) = Block (idm id) (tail t)
521 where tail (ZTail m t) = ZTail (middle m) (tail t)
522 tail (ZLast LastExit) = ZLast LastExit
523 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
526 mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
528 foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
530 ; return $ insertBlock b blocks })
531 (return emptyBlockEnv) blocks
533 fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks
534 fold_fwd_block first middle last (Block id t) z = tail t (first id z)
535 where tail (ZTail m t) z = tail t (middle m z)
536 tail (ZLast l) z = last l z
538 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
539 to_block_list (LGraph _ blocks) = eltsBlockEnv blocks
542 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
543 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
544 -- or it isn't. We use continuation-passing style.
546 prepare_for_splicing ::
547 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
549 prepare_for_splicing g single multi =
550 let FGraph _ gentry gblocks = entry g
551 ZBlock _ etail = gentry
552 in if isNullBEnv gblocks then
554 LastExit -> single etail
555 _ -> panic "bad single block"
557 case splitp_blocks is_exit gblocks of
558 Nothing -> panic "Can't find an exit block"
559 Just (gexit, gblocks) ->
560 let (gh, gl) = goto_end $ unzip gexit in
561 case gl of LastExit -> multi etail gh gblocks
562 _ -> panic "exit is not exit?!"
564 prepare_for_splicing' ::
565 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
567 prepare_for_splicing' (Graph etail gblocks) single multi =
568 if isNullBEnv gblocks then
569 case lastTail etail of
570 LastExit -> single etail
571 _ -> panic "bad single block"
573 case splitp_blocks is_exit gblocks of
574 Nothing -> panic "Can't find an exit block"
575 Just (gexit, gblocks) ->
576 let (gh, gl) = goto_end $ unzip gexit in
577 case gl of LastExit -> multi etail gh gblocks
578 _ -> panic "exit is not exit?!"
580 is_exit :: Block m l -> Bool
581 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
583 splice_head head g@(LGraph _ _) =
584 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
585 where eid = head_id head
586 splice_one_block tail' =
587 case ht_to_last head tail' of
588 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
589 _ -> panic "spliced LGraph without exit"
590 splice_many_blocks entry exit others =
591 (LGraph eid (insertBlock (zipht head entry) others), exit)
593 splice_head' head g =
594 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
595 where splice_one_block tail' =
596 case ht_to_last head tail' of
597 (head, LastExit) -> (emptyBlockEnv, head)
598 _ -> panic "spliced LGraph without exit"
599 splice_many_blocks entry exit others =
600 (insertBlock (zipht head entry) others, exit)
602 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
604 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
605 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
606 append_tails (ZLast LastExit) tail = tail
607 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
608 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
609 splice_many_blocks entry exit others =
610 Graph entry (insertBlock (zipht exit tail) others)
614 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
615 where splice_one_block tail' = -- return tail' .. tail
616 case ht_to_last (ZFirst (lg_entry g)) tail' of
618 case ht_to_block head' tail of
619 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
620 _ -> panic "entry in; garbage out"
621 _ -> panic "spliced single block without Exit"
622 splice_many_blocks entry exit others =
623 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
626 splice_head_only head g =
627 let FGraph eid gentry gblocks = entry g
629 ZBlock (ZFirst _) tail ->
630 LGraph eid (insertBlock (zipht head tail) gblocks)
631 _ -> panic "entry not at start of block?!"
633 splice_head_only' head (Graph tail gblocks) =
634 let eblock = zipht head tail in
635 LGraph (blockId eblock) (insertBlock eblock gblocks)
636 -- the offset probably should never be used, but well, it's correct for this LGraph
641 translate txm txl (LGraph eid blocks) =
642 do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
643 return $ LGraph eid blocks'
646 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
647 txblock (Block id t) expanded =
648 do blocks' <- expanded
649 txtail (ZFirst id) t blocks'
650 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
651 -- tm (BlockEnv (Block m' l'))
652 txtail h (ZTail m t) blocks' =
654 let (g, h') = splice_head h m'
655 txtail h' t (plusBlockEnv (lg_blocks g) blocks')
656 txtail h (ZLast (LastOther l)) blocks' =
658 return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
659 txtail h (ZLast LastExit) blocks' =
660 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
662 ----------------------------------------------------------------
664 ----------------------------------------------------------------
666 -- putting this code in PprCmmZ leads to circular imports :-(
668 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
671 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
674 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
677 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
680 instance (Outputable l) => Outputable (ZLast l) where
683 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
684 pprTail (ZTail m t) = ppr m $$ ppr t
685 pprTail (ZLast l) = ppr l
687 pprLast :: (Outputable l) => ZLast l -> SDoc
688 pprLast LastExit = text "<exit>"
689 pprLast (LastOther l) = ppr l
691 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
692 pprBlock (Block id tail) =
694 $$ (nest 3 (ppr tail))
696 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
697 pprLgraph g = text "{" <> text "offset" $$
698 nest 2 (vcat $ map ppr blocks) $$ text "}"
699 where blocks = postorder_dfs g
701 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
702 pprGraph (Graph tail blockenv) =
703 text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
704 where blocks = postorder_dfs_from blockenv tail