1 {-# LANGUAGE ScopedTypeVariables #-}
3 ( -- These data types and names are carefully thought out
4 BlockId(..), freshBlockId -- ToDo: BlockId should be abstract,
6 , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, insertBlock, mkBlockEnv
7 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, mkBlockSet
8 , Graph(..), LGraph(..), FGraph(..)
9 , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
10 , HavingSuccessors, succs, fold_succs
11 , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
13 -- Observers and transformers
14 -- (open to renaming suggestions here)
15 , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
16 , splice_tail, splice_head, splice_head_only', splice_head'
17 , of_block_list, to_block_list
19 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
26 , entry -- exported for the convenience of ZipDataflow, at least for now
29 -- the following functions might one day be useful and can be found
30 -- either below or in ZipCfgExtras:
31 , entry, exit, focus, focusp, unfocus
32 , ht_to_block, ht_to_last,
33 , splice_focus_entry, splice_focus_exit
34 , fold_fwd_block, foldM_fwd_block
40 #include "HsVersions.h"
42 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
104 be unique, acquiring one requires a monadic operation ('freshBlockId').
105 The primary advantage of the Graph representation is that we can build
106 a small Graph purely functionally, without entering a monad. For
107 example, during optimization we can easily rewrite a single middle
108 node into a Graph containing a sequence of two middle nodes followed by
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 data ZHead m = ZFirst BlockId | ZHead (ZHead m) m
147 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
148 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
149 -- ZTail is a sequence of middle nodes followed by a last node
151 -- | Blocks and flow graphs; see Note [Kinds of graphs]
152 data Block m l = Block BlockId (ZTail m l)
154 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
156 data LGraph m l = LGraph { lg_entry :: BlockId
157 , lg_blocks :: BlockEnv (Block m l) }
158 -- Invariant: lg_entry is in domain( lg_blocks )
160 -- | And now the zipper. The focus is between the head and tail.
161 -- We cannot ever focus on an inter-block edge.
162 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
163 data FGraph m l = FGraph { fg_entry :: BlockId
164 , fg_focus :: ZBlock m l
165 , fg_others :: BlockEnv (Block m l) }
166 -- Invariant: the block represented by 'fg_focus' is *not*
167 -- in the map 'fg_others'
169 ---- Utility functions ---
171 -- | The string argument to 'freshBlockId' was originally helpful in debugging the Quick C--
172 -- compiler, so I have kept it here even though at present it is thrown away at
173 -- this spot---there's no reason a BlockId couldn't one day carry a string.
174 freshBlockId :: String -> UniqSM BlockId
176 blockId :: Block m l -> BlockId
177 zip :: ZBlock m l -> Block m l
178 unzip :: Block m l -> ZBlock m l
180 last :: ZBlock m l -> ZLast l
181 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
183 tailOfLast :: l -> ZTail m l
185 -- | Take a head and tail and go to beginning or end. The asymmetry
186 -- in the types and names is a bit unfortunate, but 'Block m l' is
187 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
189 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
190 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
192 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
193 -- For a head, we have a head 'h' followed by a LGraph 'g'.
194 -- The entry node of 'g' gets joined to 'h', forming the entry into
195 -- the new LGraph. The exit of 'g' becomes the new head.
196 -- For both arguments and results, the order of values is the order of
197 -- control flow: before splicing, the head flows into the LGraph; after
198 -- splicing, the LGraph flows into the head.
199 -- Splicing a tail is the dual operation.
200 -- (In order to maintain the order-means-control-flow convention, the
201 -- orders are reversed.)
203 -- For example, assume
205 -- grph = (M, [M: <stuff>,
207 -- N: y:=x; LastExit])
208 -- tail = [return (y,x)]
210 -- Then splice_head head grph
211 -- = ((L, [L: x:=0; goto M,
216 -- Then splice_tail grph tail
218 -- , (???, [<blocks>,
219 -- N: y:=x; return (y,x)])
221 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
222 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
223 splice_tail :: Graph m l -> ZTail m l -> Graph m l
225 -- | We can also splice a single-entry, no-exit Graph into a head.
226 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
227 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
230 -- | A safe operation
232 -- | Conversion to and from the environment form is convenient. For
233 -- layout or dataflow, however, one will want to use 'postorder_dfs'
234 -- in order to get the blocks in an order that relates to the control
235 -- flow in the procedure.
236 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
237 to_block_list :: LGraph m l -> [Block m l] -- N log N
239 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
240 -- from the entry node. This list has the following property:
242 -- Say a "back reference" exists if one of a block's
243 -- control-flow successors precedes it in the output list
245 -- Then there are as few back references as possible
247 -- The output is suitable for use in
248 -- a forward dataflow problem. For a backward problem, simply reverse
249 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
250 -- one doesn't want to try and maintain both forward and backward
253 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
255 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
256 -- in layout order. The 'Maybe BlockId', if present, identifies the
257 -- block that will be the layout successor of the current block. This
258 -- may be useful to help an emitter omit the final 'goto' of a block
259 -- that flows directly to its layout successor.
261 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
262 -- = z <$> f (L1:B1) (Just L2)
263 -- <$> f (L2:B2) (Just L3)
264 -- <$> f (L3:B3) Nothing
265 -- where a <$> f = f a
267 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
269 -- | We can also fold over blocks in an unspecified order. The
270 -- 'ZipCfgExtras' module provides a monadic version, which we
271 -- haven't needed (else it would be here).
272 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
274 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
275 -- mapping includes the entry id!
277 -- | These translation functions are speculative. I hope eventually
278 -- they will be used in the native-code back ends ---NR
279 translate :: (m -> UniqSM (LGraph m' l')) ->
280 (l -> UniqSM (LGraph m' l')) ->
281 (LGraph m l -> UniqSM (LGraph m' l'))
284 -- | It's possible that another form of translation would be more suitable:
285 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
288 ------------------- Last nodes
290 -- | We can't make a graph out of just any old 'last node' type. A last node
291 -- has to be able to find its successors, and we need to be able to create and
292 -- identify unconditional branches. We put these capabilities in a type class.
293 -- Moreover, the property of having successors is also shared by 'Block's and
294 -- 'ZTails', so it is useful to have that property in a type class of its own.
296 class HavingSuccessors b where
297 succs :: b -> [BlockId]
298 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
300 fold_succs add l z = foldr add z $ succs l
302 class HavingSuccessors l => LastNode l where
303 mkBranchNode :: BlockId -> l
304 isBranchNode :: l -> Bool
305 branchNodeTarget :: l -> BlockId -- panics if not branch node
306 -- ^ N.B. This interface seems to make for more congenial clients than a
307 -- single function of type 'l -> Maybe BlockId'
309 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
311 succs (LastOther l) = succs l
312 fold_succs _ LastExit z = z
313 fold_succs f (LastOther l) z = fold_succs f l z
315 instance LastNode l => LastNode (ZLast l) where
316 mkBranchNode id = LastOther $ mkBranchNode id
317 isBranchNode LastExit = False
318 isBranchNode (LastOther l) = isBranchNode l
319 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
320 branchNodeTarget (LastOther l) = branchNodeTarget l
322 instance LastNode l => HavingSuccessors (ZBlock m l) where
323 succs b = succs (last b)
325 instance LastNode l => HavingSuccessors (Block m l) where
326 succs b = succs (unzip b)
328 instance LastNode l => HavingSuccessors (ZTail m l) where
329 succs b = succs (lastTail b)
333 -- ================ IMPLEMENTATION ================--
335 ----- block manipulations
337 blockId (Block id _) = id
339 freshBlockId _ = do { u <- getUniqueUs; return $ BlockId u }
341 -- | Convert block between forms.
342 -- These functions are tail-recursive, so we can go as deep as we like
343 -- without fear of stack overflow.
345 ht_to_block head tail = case head of
346 ZFirst id -> Block id tail
347 ZHead h m -> ht_to_block h (ZTail m tail)
349 ht_to_last head (ZLast l) = (head, l)
350 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
352 zipht h t = ht_to_block h t
353 zip (ZBlock h t) = ht_to_block h t
354 goto_end (ZBlock h t) = ht_to_last h t
356 unzip (Block id t) = ZBlock (ZFirst id) t
358 head_id :: ZHead m -> BlockId
359 head_id (ZFirst id) = id
360 head_id (ZHead h _) = head_id h
362 last (ZBlock _ t) = lastTail t
364 lastTail :: ZTail m l -> ZLast l
365 lastTail (ZLast l) = l
366 lastTail (ZTail _ t) = lastTail t
368 tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client
371 ------------------ simple graph manipulations
373 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
374 focus id (LGraph entry blocks) =
375 case lookupBlockEnv blocks id of
376 Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
377 Nothing -> panic "asked for nonexistent block in flow graph"
379 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
380 entry g@(LGraph eid _) = focus eid g
382 -- | pull out a block satisfying the predicate, if any
383 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
384 Maybe (Block m l, BlockEnv (Block m l))
385 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
386 where scan b (yes, no) =
388 Nothing | p b -> (Just b, no)
389 | otherwise -> (yes, insertBlock b no)
390 Just _ -> (yes, insertBlock b no)
391 lift (Nothing, _) = Nothing
392 lift (Just b, bs) = Just (b, bs)
394 -- | 'insertBlock' should not be used to *replace* an existing block
395 -- but only to insert a new one
396 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
398 ASSERT (isNothing $ lookupBlockEnv bs id)
399 extendBlockEnv bs id b
402 -- | Used in assertions; tells if a graph has exactly one exit
403 single_exit :: LGraph l m -> Bool
404 single_exit g = foldUFM check 0 (lg_blocks g) == 1
405 where check block count = case last (unzip block) of
406 LastExit -> count + (1 :: Int)
409 -- | Used in assertions; tells if a graph has exactly one exit
410 single_exitg :: Graph l m -> Bool
411 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
412 where add block count = count + exit_count (last (unzip block))
413 exit_count LastExit = 1 :: Int
416 ------------------ graph traversals
418 -- | This is the most important traversal over this data structure. It drops
419 -- unreachable code and puts blocks in an order that is good for solving forward
420 -- dataflow problems quickly. The reverse order is good for solving backward
421 -- dataflow problems quickly. The forward order is also reasonably good for
422 -- emitting instructions, except that it will not usually exploit Forrest
423 -- Baskett's trick of eliminating the unconditional branch from a loop. For
424 -- that you would need a more serious analysis, probably based on dominators, to
425 -- identify loop headers.
427 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
428 -- representation, when for most purposes the plain 'Graph' representation is
429 -- more mathematically elegant (but results in more complicated code).
431 -- Here's an easy way to go wrong! Consider
435 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
436 -- Better to geot [A,B,C,D]
439 postorder_dfs' :: LastNode l => LGraph m l -> [Block m l]
440 postorder_dfs' g@(LGraph _ blocks) =
441 let FGraph _ eblock _ = entry g
442 in vnode (zip eblock) (\acc _visited -> acc) [] emptyBlockSet
445 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
446 vnode block@(Block id _) cont acc visited =
447 if elemBlockSet id visited then
450 vchildren block (get_children block) cont acc (extendBlockSet visited id)
451 vchildren block bs cont acc visited =
452 let next children acc visited =
453 case children of [] -> cont (block : acc) visited
454 (b:bs) -> vnode b (next bs) acc visited
455 in next bs acc visited
456 get_children block = foldl add_id [] (succs block)
457 add_id rst id = case lookupBlockEnv blocks id of
461 postorder_dfs g@(LGraph _ blockenv) =
462 let FGraph id eblock _ = entry g
464 postorder_dfs_from_except blockenv eblock (unitUniqSet id)
465 dfs2 = postorder_dfs' g
466 -- in ASSERT (map blockId dfs1 == map blockId dfs2) dfs2
467 in if (map blockId dfs1 == map blockId dfs2) then dfs2 else panic "inconsistent DFS"
470 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
471 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
473 postorder_dfs_from_except :: forall b m l . (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
474 postorder_dfs_from_except blocks b visited =
475 vchildren (get_children b) (\acc _visited -> acc) [] visited
478 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
479 vnode block@(Block id _) cont acc visited =
480 if elemBlockSet id visited then
483 let cont' acc visited = cont (block:acc) visited in
484 vchildren (get_children block) cont' acc (extendBlockSet visited id)
485 vchildren bs cont acc visited =
486 let next children acc visited =
487 case children of [] -> cont acc visited
488 (b:bs) -> vnode b (next bs) acc visited
489 in next bs acc visited
490 get_children block = foldl add_id [] (succs block)
491 add_id rst id = case lookupBlockEnv blocks id of
496 -- | Slightly more complicated than the usual fold because we want to tell block
497 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
498 -- 'goto b2', the goto can be omitted.
500 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
501 where fold blocks z =
502 case blocks of [] -> z
504 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
505 nextlabel (Block id _) =
506 if id == eid then panic "entry as successor"
509 -- | The rest of the traversals are straightforward
511 map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
512 where block (Block id t) = Block (idm id) (tail t)
513 tail (ZTail m t) = ZTail (middle m) (tail t)
514 tail (ZLast LastExit) = ZLast LastExit
515 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
517 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
519 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
520 to_block_list (LGraph _ blocks) = eltsUFM blocks
525 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
526 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
527 -- or it isn't. We use continuation-passing style.
529 prepare_for_splicing ::
530 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
532 prepare_for_splicing g single multi =
533 let FGraph _ gentry gblocks = entry g
534 ZBlock _ etail = gentry
535 in if isNullUFM gblocks then
537 LastExit -> single etail
538 _ -> panic "bad single block"
540 case splitp_blocks is_exit gblocks of
541 Nothing -> panic "Can't find an exit block"
542 Just (gexit, gblocks) ->
543 let (gh, gl) = goto_end $ unzip gexit in
544 case gl of LastExit -> multi etail gh gblocks
545 _ -> panic "exit is not exit?!"
547 prepare_for_splicing' ::
548 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
550 prepare_for_splicing' (Graph etail gblocks) single multi =
551 if isNullUFM gblocks then
552 case lastTail etail of
553 LastExit -> single etail
554 _ -> panic "bad single block"
556 case splitp_blocks is_exit gblocks of
557 Nothing -> panic "Can't find an exit block"
558 Just (gexit, gblocks) ->
559 let (gh, gl) = goto_end $ unzip gexit in
560 case gl of LastExit -> multi etail gh gblocks
561 _ -> panic "exit is not exit?!"
563 is_exit :: Block m l -> Bool
564 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
567 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
568 where eid = head_id head
569 splice_one_block tail' =
570 case ht_to_last head tail' of
571 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
572 _ -> panic "spliced LGraph without exit"
573 splice_many_blocks entry exit others =
574 (LGraph eid (insertBlock (zipht head entry) others), exit)
576 splice_head' head g =
577 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
578 where splice_one_block tail' =
579 case ht_to_last head tail' of
580 (head, LastExit) -> (emptyBlockEnv, head)
581 _ -> panic "spliced LGraph without exit"
582 splice_many_blocks entry exit others =
583 (insertBlock (zipht head entry) others, exit)
585 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
587 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
588 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
589 append_tails (ZLast LastExit) tail = tail
590 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
591 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
592 splice_many_blocks entry exit others =
593 Graph entry (insertBlock (zipht exit tail) others)
597 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
598 where splice_one_block tail' = -- return tail' .. tail
599 case ht_to_last (ZFirst (lg_entry g)) tail' of
601 case ht_to_block head' tail of
602 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
603 _ -> panic "entry in; garbage out"
604 _ -> panic "spliced single block without Exit"
605 splice_many_blocks entry exit others =
606 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
609 splice_head_only head g =
610 let FGraph eid gentry gblocks = entry g
612 ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
613 _ -> panic "entry not at start of block?!"
615 splice_head_only' head (Graph tail gblocks) =
616 let eblock = zipht head tail in
617 LGraph (blockId eblock) (insertBlock eblock gblocks)
622 translate txm txl (LGraph eid blocks) =
623 do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
624 return $ LGraph eid blocks'
627 -- Block m l -> UniqSM (BlockEnv (Block m' l')) -> UniqSM (BlockEnv (Block m' l'))
628 txblock (Block id t) expanded =
629 do blocks' <- expanded
630 txtail (ZFirst id) t blocks'
631 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
632 -- UniqSM (BlockEnv (Block m' l'))
633 txtail h (ZTail m t) blocks' =
635 let (g, h') = splice_head h m'
636 txtail h' t (plusUFM (lg_blocks g) blocks')
637 txtail h (ZLast (LastOther l)) blocks' =
639 return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
640 txtail h (ZLast LastExit) blocks' =
641 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
643 ----------------------------------------------------------------
644 --- Block Ids, their environments, and their sets
646 {- Note [Unique BlockId]
647 ~~~~~~~~~~~~~~~~~~~~~~~~
648 Although a 'BlockId' is a local label, for reasons of implementation,
649 'BlockId's must be unique within an entire compilation unit. The reason
650 is that each local label is mapped to an assembly-language label, and in
651 most assembly languages allow, a label is visible throughout the enitre
652 compilation unit in which it appears.
655 newtype BlockId = BlockId Unique
658 instance Uniquable BlockId where
659 getUnique (BlockId u) = u
661 instance Show BlockId where
662 show (BlockId u) = show u
664 instance Outputable BlockId where
665 ppr = ppr . getUnique
668 type BlockEnv a = UniqFM {- BlockId -} a
669 emptyBlockEnv :: BlockEnv a
670 emptyBlockEnv = emptyUFM
671 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
672 lookupBlockEnv = lookupUFM
673 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
674 extendBlockEnv = addToUFM
675 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
676 mkBlockEnv = listToUFM
678 type BlockSet = UniqSet BlockId
679 emptyBlockSet :: BlockSet
680 emptyBlockSet = emptyUniqSet
681 elemBlockSet :: BlockId -> BlockSet -> Bool
682 elemBlockSet = elementOfUniqSet
683 extendBlockSet :: BlockSet -> BlockId -> BlockSet
684 extendBlockSet = addOneToUniqSet
685 mkBlockSet :: [BlockId] -> BlockSet
686 mkBlockSet = mkUniqSet
688 ----------------------------------------------------------------
690 ----------------------------------------------------------------
692 -- putting this code in PprCmmZ leads to circular imports :-(
694 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
697 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
698 pprTail (ZTail m t) = ppr m $$ ppr t
699 pprTail (ZLast LastExit) = text "<exit>"
700 pprTail (ZLast (LastOther l)) = ppr l
702 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
703 pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
704 where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
705 blocks = postorder_dfs g
707 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
708 pprGraph (Graph tail blockenv) =
709 text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}"
710 where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
711 blocks = postorder_dfs_from blockenv tail
713 _unused :: FS.FastString