2 ( -- These data types and names are carefully thought out
3 Graph(..), LGraph(..), FGraph(..)
4 , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
5 , StackInfo(..), emptyStackInfo
7 , HavingSuccessors, succs, fold_succs
8 , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
10 -- Observers and transformers
11 -- (open to renaming suggestions here)
12 , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
13 , splice_tail, splice_head, splice_head_only', splice_head'
14 , of_block_list, to_block_list
16 , map_blocks, map_one_block, map_nodes, mapM_blocks
17 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
19 , fold_blocks, fold_fwd_block
24 , entry -- exported for the convenience of ZipDataflow0, at least for now
27 -- the following functions might one day be useful and can be found
28 -- either below or in ZipCfgExtras:
29 , entry, exit, focus, focusp, unfocus
30 , ht_to_block, ht_to_last,
31 , splice_focus_entry, splice_focus_exit
38 #include "HsVersions.h"
40 import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
41 , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet
42 , delFromBlockEnv, foldBlockEnv', mapBlockEnv
43 , eltsBlockEnv, isNullBEnv, plusBlockEnv)
44 import CmmExpr ( UserOfLocalRegs(..) )
47 import Outputable hiding (empty)
51 import Prelude hiding (zip, unzip, last)
53 -------------------------------------------------------------------------
54 -- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
55 -------------------------------------------------------------------------
58 This module defines datatypes used to represent control-flow graphs,
59 along with some functions for analyzing and splicing graphs.
60 Functions for building graphs are found in a separate module 'MkZipCfg'.
62 Every graph has a distinguished entry point. A graph has at least one
63 exit; most exits are instructions (or statements) like 'jump' or
64 'return', which transfer control to other procedures, but a graph may
65 have up to one 'fall through' exit. (A graph that represents an
66 entire Haskell or C-- procedure does not have a 'fall through' exit.)
68 A graph is a collection of basic blocks. A basic block begins with a
69 label (unique id; see Note [Unique BlockId]) which is followed by a
70 sequence of zero or more 'middle' nodes; the basic block ends with a
71 'last' node. Each 'middle' node is a single-entry, single-exit,
72 uninterruptible computation. A 'last' node is a single-entry,
73 multiple-exit computation. A last node may have zero or more successors,
74 which are identified by their unique ids.
76 A special case of last node is the ``default exit,'' which represents
77 'falling off the end' of the graph. Such a node is always represented by
78 the data constructor 'LastExit'. A graph may contain at most one
79 'LastExit' node, and a graph representing a full procedure should not
80 contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
81 graphs together, either during graph construction (see module 'MkZipCfg')
82 or during optimization (see module 'ZipDataflow').
84 A graph is parameterized over the types of middle and last nodes. Each of
85 these types will typically be instantiated with a subset of C-- statements
86 (see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
87 implemented as of August 2007).
90 Note [Kinds of Graphs]
91 ~~~~~~~~~~~~~~~~~~~~~~
92 This module exposes three representations of graphs. In order of
93 increasing complexity, they are:
95 Graph m l The basic graph with its distinguished entry point
97 LGraph m l A graph with a *labelled* entry point
99 FGraph m l A labelled graph with the *focus* on a particular edge
101 There are three types because each type offers a slightly different
102 invariant or cost model.
104 * The distinguished entry of a Graph has no label. Because labels must be
105 unique, acquiring one requires a supply of Unique labels (BlockId's).
106 The primary advantage of the Graph representation is that we can build a
107 small Graph purely functionally, without needing a fresh BlockId or
108 Unique. For example, during optimization we can easily rewrite a single
109 middle node into a Graph containing a sequence of two middle nodes
110 followed by LastExit.
112 * In an LGraph, every basic block is labelled. The primary advantage of
113 this representation is its simplicity: each basic block can be treated
114 like any other. This representation is used for mapping, folding, and
115 translation, as well as layout.
117 Like any graph, an LGraph still has a distinguished entry point,
118 which you can discover using 'lg_entry'.
120 * An FGraph is an LGraph with the *focus* on one particular edge. The
121 primary advantage of this representation is that it provides
122 constant-time access to the nodes connected by that edge, and it also
123 allows constant-time, functional *replacement* of those nodes---in the
124 style of Huet's 'zipper'.
126 None of these representations is ideally suited to the incremental
127 construction of large graphs. A separate module, 'MkZipCfg', provides a
128 fourth representation that is asymptotically optimal for such construction.
132 --------------- Representation --------------------
134 -- | A basic block is a 'first' node, followed by zero or more 'middle'
135 -- nodes, followed by a 'last' node.
137 -- eventually this module should probably replace the original Cmm, but for
138 -- now we leave it to dynamic invariants what can be found where
141 = LastExit -- fall through; used for the block that has no last node
142 -- LastExit is a device used only for graphs under
143 -- construction, or framgments of graph under optimisation,
144 -- so we don't want to pollute the 'l' type parameter with it
147 --So that we don't have orphan instances, this goes here or in CmmExpr.
148 --At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
149 --but there's no need for non-Haskell98 instances for that.
150 instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
151 foldRegsUsed f z (LastOther l) = foldRegsUsed f z l
152 foldRegsUsed _f z LastExit = z
155 data ZHead m = ZFirst BlockId StackInfo
157 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
158 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
159 -- ZTail is a sequence of middle nodes followed by a last node
161 -- | Blocks and flow graphs; see Note [Kinds of graphs]
163 -- For each block, we may need two pieces of information about the stack:
164 -- 1. If the block is a procpoint, how many bytes are used to pass
165 -- arguments on the stack?
166 -- 2. If the block succeeds a call, we need to generate an infotable
167 -- that describes the stack layout... but only up to the update frame!
168 -- Note that a block can be a proc point without requiring an infotable.
169 data StackInfo = StackInfo { argBytes :: Maybe Int
170 , returnOff :: Maybe Int }
172 emptyStackInfo :: StackInfo
173 emptyStackInfo = StackInfo Nothing Nothing
175 data Block m l = Block { bid :: BlockId
176 , stackInfo :: StackInfo
177 , tail :: ZTail m l }
179 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
181 data LGraph m l = LGraph { lg_entry :: BlockId
182 , lg_argoffset :: Int -- space (bytes) for incoming args
183 , lg_blocks :: BlockEnv (Block m l)}
184 -- Invariant: lg_entry is in domain( lg_blocks )
186 -- | And now the zipper. The focus is between the head and tail.
187 -- We cannot ever focus on an inter-block edge.
188 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
189 data FGraph m l = FGraph { fg_entry :: BlockId
190 , fg_focus :: ZBlock m l
191 , fg_others :: BlockEnv (Block m l) }
192 -- Invariant: the block represented by 'fg_focus' is *not*
193 -- in the map 'fg_others'
195 ---- Utility functions ---
197 blockId :: Block m l -> BlockId
198 zip :: ZBlock m l -> Block m l
199 unzip :: Block m l -> ZBlock m l
201 last :: ZBlock m l -> ZLast l
202 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
204 tailOfLast :: l -> ZTail m l
206 -- | Take a head and tail and go to beginning or end. The asymmetry
207 -- in the types and names is a bit unfortunate, but 'Block m l' is
208 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
210 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
211 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
213 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
214 -- For a head, we have a head 'h' followed by a LGraph 'g'.
215 -- The entry node of 'g' gets joined to 'h', forming the entry into
216 -- the new LGraph. The exit of 'g' becomes the new head.
217 -- For both arguments and results, the order of values is the order of
218 -- control flow: before splicing, the head flows into the LGraph; after
219 -- splicing, the LGraph flows into the head.
220 -- Splicing a tail is the dual operation.
221 -- (In order to maintain the order-means-control-flow convention, the
222 -- orders are reversed.)
224 -- For example, assume
226 -- grph = (M, [M: <stuff>,
228 -- N: y:=x; LastExit])
229 -- tail = [return (y,x)]
231 -- Then splice_head head grph
232 -- = ((L, [L: x:=0; goto M,
237 -- Then splice_tail grph tail
239 -- , (???, [<blocks>,
240 -- N: y:=x; return (y,x)])
242 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
243 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
244 splice_tail :: Graph m l -> ZTail m l -> Graph m l
246 -- | We can also splice a single-entry, no-exit Graph into a head.
247 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
248 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
251 -- | A safe operation
253 -- | Conversion to and from the environment form is convenient. For
254 -- layout or dataflow, however, one will want to use 'postorder_dfs'
255 -- in order to get the blocks in an order that relates to the control
256 -- flow in the procedure.
257 of_block_list :: BlockId -> Int -> [Block m l] -> LGraph m l -- N log N
258 to_block_list :: LGraph m l -> [Block m l] -- N log N
260 -- | Conversion from LGraph to Graph
261 graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
262 graphOfLGraph (LGraph eid _ blocks) = Graph (ZLast $ mkBranchNode eid) blocks
265 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
266 -- from the entry node. This list has the following property:
268 -- Say a "back reference" exists if one of a block's
269 -- control-flow successors precedes it in the output list
271 -- Then there are as few back references as possible
273 -- The output is suitable for use in
274 -- a forward dataflow problem. For a backward problem, simply reverse
275 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
276 -- one doesn't want to try and maintain both forward and backward
279 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
281 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
282 -- in layout order. The 'Maybe BlockId', if present, identifies the
283 -- block that will be the layout successor of the current block. This
284 -- may be useful to help an emitter omit the final 'goto' of a block
285 -- that flows directly to its layout successor.
287 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
288 -- = z <$> f (L1:B1) (Just L2)
289 -- <$> f (L2:B2) (Just L3)
290 -- <$> f (L3:B3) Nothing
291 -- where a <$> f = f a
293 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
295 -- | We can also fold over blocks in an unspecified order. The
296 -- 'ZipCfgExtras' module provides a monadic version, which we
297 -- haven't needed (else it would be here).
298 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
300 -- | Fold from first to last
301 fold_fwd_block :: (BlockId -> StackInfo -> a -> a) -> (m -> a -> a) ->
302 (ZLast l -> a -> a) -> Block m l -> a -> a
304 map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
306 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
307 -- mapping includes the entry id!
309 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
310 mapM_blocks :: Monad mm
311 => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
313 -- | These translation functions are speculative. I hope eventually
314 -- they will be used in the native-code back ends ---NR
315 translate :: Monad tm =>
316 (m -> tm (LGraph m' l')) ->
317 (l -> tm (LGraph m' l')) ->
318 (LGraph m l -> tm (LGraph m' l'))
321 -- | It's possible that another form of translation would be more suitable:
322 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
325 ------------------- Last nodes
327 -- | We can't make a graph out of just any old 'last node' type. A last node
328 -- has to be able to find its successors, and we need to be able to create and
329 -- identify unconditional branches. We put these capabilities in a type class.
330 -- Moreover, the property of having successors is also shared by 'Block's and
331 -- 'ZTails', so it is useful to have that property in a type class of its own.
333 class HavingSuccessors b where
334 succs :: b -> [BlockId]
335 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
337 fold_succs add l z = foldr add z $ succs l
339 class HavingSuccessors l => LastNode l where
340 mkBranchNode :: BlockId -> l
341 isBranchNode :: l -> Bool
342 branchNodeTarget :: l -> BlockId -- panics if not branch node
343 -- ^ N.B. This interface seems to make for more congenial clients than a
344 -- single function of type 'l -> Maybe BlockId'
346 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
348 succs (LastOther l) = succs l
349 fold_succs _ LastExit z = z
350 fold_succs f (LastOther l) z = fold_succs f l z
352 instance LastNode l => LastNode (ZLast l) where
353 mkBranchNode id = LastOther $ mkBranchNode id
354 isBranchNode LastExit = False
355 isBranchNode (LastOther l) = isBranchNode l
356 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
357 branchNodeTarget (LastOther l) = branchNodeTarget l
359 instance LastNode l => HavingSuccessors (ZBlock m l) where
360 succs b = succs (last b)
362 instance LastNode l => HavingSuccessors (Block m l) where
363 succs b = succs (unzip b)
365 instance LastNode l => HavingSuccessors (ZTail m l) where
366 succs b = succs (lastTail b)
370 -- ================ IMPLEMENTATION ================--
372 ----- block manipulations
374 blockId (Block id _ _) = id
376 -- | Convert block between forms.
377 -- These functions are tail-recursive, so we can go as deep as we like
378 -- without fear of stack overflow.
380 ht_to_block head tail = case head of
381 ZFirst id off -> Block id off tail
382 ZHead h m -> ht_to_block h (ZTail m tail)
384 ht_to_last head (ZLast l) = (head, l)
385 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
387 zipht h t = ht_to_block h t
388 zip (ZBlock h t) = ht_to_block h t
389 goto_end (ZBlock h t) = ht_to_last h t
391 unzip (Block id off t) = ZBlock (ZFirst id off) t
393 head_id :: ZHead m -> BlockId
394 head_id (ZFirst id _) = id
395 head_id (ZHead h _) = head_id h
397 last (ZBlock _ t) = lastTail t
399 lastTail :: ZTail m l -> ZLast l
400 lastTail (ZLast l) = l
401 lastTail (ZTail _ t) = lastTail t
403 tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
406 ------------------ simple graph manipulations
408 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
409 focus id (LGraph entry _ blocks) =
410 case lookupBlockEnv blocks id of
411 Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
412 Nothing -> panic "asked for nonexistent block in flow graph"
414 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
415 entry g@(LGraph eid _ _) = focus eid g
417 -- | pull out a block satisfying the predicate, if any
418 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
419 Maybe (Block m l, BlockEnv (Block m l))
420 splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks
421 where scan b (yes, no) =
423 Nothing | p b -> (Just b, no)
424 | otherwise -> (yes, insertBlock b no)
425 Just _ -> (yes, insertBlock b no)
426 lift (Nothing, _) = Nothing
427 lift (Just b, bs) = Just (b, bs)
429 -- | 'insertBlock' should not be used to /replace/ an existing block
430 -- but only to insert a new one
431 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
433 ASSERT (isNothing $ lookupBlockEnv bs id)
434 extendBlockEnv bs id b
437 -- | Used in assertions; tells if a graph has exactly one exit
438 single_exit :: LGraph l m -> Bool
439 single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1
440 where check block count = case last (unzip block) of
441 LastExit -> count + (1 :: Int)
444 -- | Used in assertions; tells if a graph has exactly one exit
445 single_exitg :: Graph l m -> Bool
446 single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1
447 where add block count = count + exit_count (last (unzip block))
448 exit_count LastExit = 1 :: Int
451 ------------------ graph traversals
453 -- | This is the most important traversal over this data structure. It drops
454 -- unreachable code and puts blocks in an order that is good for solving forward
455 -- dataflow problems quickly. The reverse order is good for solving backward
456 -- dataflow problems quickly. The forward order is also reasonably good for
457 -- emitting instructions, except that it will not usually exploit Forrest
458 -- Baskett's trick of eliminating the unconditional branch from a loop. For
459 -- that you would need a more serious analysis, probably based on dominators, to
460 -- identify loop headers.
462 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
463 -- representation, when for most purposes the plain 'Graph' representation is
464 -- more mathematically elegant (but results in more complicated code).
466 -- Here's an easy way to go wrong! Consider
472 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
473 -- Better to get [A,B,C,D]
476 postorder_dfs g@(LGraph _ _ blockenv) =
477 let FGraph id eblock _ = entry g in
478 zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
480 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
481 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
482 postorder_dfs_from_except blocks b visited =
483 vchildren (get_children b) (\acc _visited -> acc) [] visited
486 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
487 vnode block@(Block id _ _) cont acc visited =
488 if elemBlockSet id visited then
491 let cont' acc visited = cont (block:acc) visited in
492 vchildren (get_children block) cont' acc (extendBlockSet visited id)
493 vchildren bs cont acc visited =
494 let next children acc visited =
495 case children of [] -> cont acc visited
496 (b:bs) -> vnode b (next bs) acc visited
497 in next bs acc visited
498 get_children block = foldl add_id [] (succs block)
499 add_id rst id = case lookupBlockEnv blocks id of
504 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
505 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
509 -- | Slightly more complicated than the usual fold because we want to tell block
510 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
511 -- 'goto b2', the goto can be omitted.
513 fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z
514 where fold blocks z =
515 case blocks of [] -> z
517 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
518 nextlabel (Block id _ _) =
519 if id == eid then panic "entry as successor"
522 -- | The rest of the traversals are straightforward
524 map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks)
526 map_nodes idm middle last (LGraph eid off blocks) =
527 LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks)
529 map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t)
530 where tail (ZTail m t) = ZTail (middle m) (tail t)
531 tail (ZLast LastExit) = ZLast LastExit
532 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
535 mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off
537 foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
539 ; return $ insertBlock b blocks })
540 (return emptyBlockEnv) blocks
542 fold_blocks f z (LGraph _ _ blocks) = foldBlockEnv' f z blocks
543 fold_fwd_block first middle last (Block id off t) z = tail t (first id off z)
544 where tail (ZTail m t) z = tail t (middle m z)
545 tail (ZLast l) z = last l z
547 of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks
548 to_block_list (LGraph _ _ blocks) = eltsBlockEnv blocks
551 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
552 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
553 -- or it isn't. We use continuation-passing style.
555 prepare_for_splicing ::
556 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
558 prepare_for_splicing g single multi =
559 let FGraph _ gentry gblocks = entry g
560 ZBlock _ etail = gentry
561 in if isNullBEnv gblocks then
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 prepare_for_splicing' ::
574 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
576 prepare_for_splicing' (Graph etail gblocks) single multi =
577 if isNullBEnv gblocks then
578 case lastTail etail of
579 LastExit -> single etail
580 _ -> panic "bad single block"
582 case splitp_blocks is_exit gblocks of
583 Nothing -> panic "Can't find an exit block"
584 Just (gexit, gblocks) ->
585 let (gh, gl) = goto_end $ unzip gexit in
586 case gl of LastExit -> multi etail gh gblocks
587 _ -> panic "exit is not exit?!"
589 is_exit :: Block m l -> Bool
590 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
592 splice_head head g@(LGraph _ off _) =
593 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
594 where eid = head_id head
595 splice_one_block tail' =
596 case ht_to_last head tail' of
597 (head, LastExit) -> (LGraph eid off emptyBlockEnv, head)
598 _ -> panic "spliced LGraph without exit"
599 splice_many_blocks entry exit others =
600 (LGraph eid off (insertBlock (zipht head entry) others), exit)
602 splice_head' head g =
603 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
604 where splice_one_block tail' =
605 case ht_to_last head tail' of
606 (head, LastExit) -> (emptyBlockEnv, head)
607 _ -> panic "spliced LGraph without exit"
608 splice_many_blocks entry exit others =
609 (insertBlock (zipht head entry) others, exit)
611 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
613 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
614 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
615 append_tails (ZLast LastExit) tail = tail
616 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
617 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
618 splice_many_blocks entry exit others =
619 Graph entry (insertBlock (zipht exit tail) others)
623 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
624 where splice_one_block tail' = -- return tail' .. tail
625 case ht_to_last (ZFirst (lg_entry g)) tail' of
627 case ht_to_block head' tail of
628 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
629 _ -> panic "entry in; garbage out"
630 _ -> panic "spliced single block without Exit"
631 splice_many_blocks entry exit others =
632 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
635 splice_head_only head g =
636 let FGraph eid gentry gblocks = entry g
638 ZBlock (ZFirst _ _) tail ->
639 LGraph eid 0 (insertBlock (zipht head tail) gblocks)
640 _ -> panic "entry not at start of block?!"
642 splice_head_only' head (Graph tail gblocks) =
643 let eblock = zipht head tail in
644 LGraph (blockId eblock) 0 (insertBlock eblock gblocks)
645 -- the offset probably should never be used, but well, it's correct for this LGraph
650 translate txm txl (LGraph eid off blocks) =
651 do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
652 return $ LGraph eid off blocks'
655 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
656 txblock (Block id boff t) expanded =
657 do blocks' <- expanded
658 txtail (ZFirst id boff) t blocks'
659 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
660 -- tm (BlockEnv (Block m' l'))
661 txtail h (ZTail m t) blocks' =
663 let (g, h') = splice_head h m'
664 txtail h' t (plusBlockEnv (lg_blocks g) blocks')
665 txtail h (ZLast (LastOther l)) blocks' =
667 return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
668 txtail h (ZLast LastExit) blocks' =
669 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
671 ----------------------------------------------------------------
673 ----------------------------------------------------------------
675 -- putting this code in PprCmmZ leads to circular imports :-(
677 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
680 instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
683 instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
686 instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
689 instance Outputable StackInfo where
692 instance (Outputable l) => Outputable (ZLast l) where
695 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
696 pprTail (ZTail m t) = ppr m $$ ppr t
697 pprTail (ZLast l) = ppr l
699 pprLast :: (Outputable l) => ZLast l -> SDoc
700 pprLast LastExit = text "<exit>"
701 pprLast (LastOther l) = ppr l
703 pprStackInfo :: StackInfo -> SDoc
705 text "<arg bytes:" <+> ppr (argBytes cs) <+>
706 text "ret offset:" <+> ppr (returnOff cs) <> text ">"
708 pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
709 pprBlock (Block id stackInfo tail) =
710 ppr id <> parens (ppr stackInfo) <> colon
711 $$ (nest 3 (ppr tail))
713 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
714 pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$
715 nest 2 (vcat $ map ppr blocks) $$ text "}"
716 where blocks = postorder_dfs g
718 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
719 pprGraph (Graph tail blockenv) =
720 text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
721 where blocks = postorder_dfs_from blockenv tail