2 ( -- These data types and names are carefully thought out
3 BlockId(..) -- ToDo: BlockId should be abstract, but it isn't yet
4 , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, insertBlock, mkBlockEnv
5 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, mkBlockSet
6 , Graph(..), LGraph(..), FGraph(..)
7 , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
8 , HavingSuccessors, succs, fold_succs
9 , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
11 -- Observers and transformers
12 -- (open to renaming suggestions here)
13 , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
14 , splice_tail, splice_head, splice_head_only', splice_head'
15 , of_block_list, to_block_list
16 , map_blocks, map_nodes
17 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
24 , entry -- exported for the convenience of ZipDataflow, 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
32 , fold_fwd_block, foldM_fwd_block
38 #include "HsVersions.h"
40 import Outputable hiding (empty)
47 import Prelude hiding (zip, unzip, last)
49 -------------------------------------------------------------------------
50 -- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
51 -------------------------------------------------------------------------
54 This module defines datatypes used to represent control-flow graphs,
55 along with some functions for analyzing and splicing graphs.
56 Functions for building graphs are found in a separate module 'MkZipCfg'.
58 Every graph has a distinguished entry point. A graph has at least one
59 exit; most exits are instructions (or statements) like 'jump' or
60 'return', which transfer control to other procedures, but a graph may
61 have up to one 'fall through' exit. (A graph that represents an
62 entire Haskell or C-- procedure does not have a 'fall through' exit.)
64 A graph is a collection of basic blocks. A basic block begins with a
65 label (unique id; see Note [Unique BlockId]) which is followed by a
66 sequence of zero or more 'middle' nodes; the basic block ends with a
67 'last' node. Each 'middle' node is a single-entry, single-exit,
68 uninterruptible computation. A 'last' node is a single-entry,
69 multiple-exit computation. A last node may have zero or more successors,
70 which are identified by their unique ids.
72 A special case of last node is the ``default exit,'' which represents
73 'falling off the end' of the graph. Such a node is always represented by
74 the data constructor 'LastExit'. A graph may contain at most one
75 'LastExit' node, and a graph representing a full procedure should not
76 contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
77 graphs together, either during graph construction (see module 'MkZipCfg')
78 or during optimization (see module 'ZipDataflow').
80 A graph is parameterized over the types of middle and last nodes. Each of
81 these types will typically be instantiated with a subset of C-- statements
82 (see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
83 implemented as of August 2007).
86 Note [Kinds of Graphs]
87 ~~~~~~~~~~~~~~~~~~~~~~
88 This module exposes three representations of graphs. In order of
89 increasing complexity, they are:
91 Graph m l The basic graph with its distinguished entry point
93 LGraph m l A graph with a *labelled* entry point
95 FGraph m l A labelled graph with the *focus* on a particular edge
97 There are three types because each type offers a slightly different
98 invariant or cost model.
100 * The distinguished entry of a Graph has no label. Because labels must be
101 unique, acquiring one requires a supply of Unique labels (BlockId's).
102 The primary advantage of the Graph representation is that we can build a
103 small Graph purely functionally, without needing a fresh BlockId or
104 Unique. For example, during optimization we can easily rewrite a single
105 middle node into a Graph containing a sequence of two middle nodes
106 followed by LastExit.
108 * In an LGraph, every basic block is labelled. The primary advantage of
109 this representation is its simplicity: each basic block can be treated
110 like any other. This representation is used for mapping, folding, and
111 translation, as well as layout.
113 Like any graph, an LGraph still has a distinguished entry point,
114 which you can discover using 'lg_entry'.
116 * An FGraph is an LGraph with the *focus* on one particular edge. The
117 primary advantage of this representation is that it provides
118 constant-time access to the nodes connected by that edge, and it also
119 allows constant-time, functional *replacement* of those nodes---in the
120 style of Huet's 'zipper'.
122 None of these representations is ideally suited to the incremental
123 construction of large graphs. A separate module, 'MkZipCfg', provides a
124 fourth representation that is asymptotically optimal for such construction.
128 --------------- Representation --------------------
130 -- | A basic block is a 'first' node, followed by zero or more 'middle'
131 -- nodes, followed by a 'last' node.
133 -- eventually this module should probably replace the original Cmm, but for
134 -- now we leave it to dynamic invariants what can be found where
137 = LastExit -- fall through; used for the block that has no last node
138 -- LastExit is a device used only for graphs under
139 -- construction, or framgments of graph under optimisation,
140 -- so we don't want to pollute the 'l' type parameter with it
143 data ZHead m = ZFirst BlockId | ZHead (ZHead m) m
144 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
145 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
146 -- ZTail is a sequence of middle nodes followed by a last node
148 -- | Blocks and flow graphs; see Note [Kinds of graphs]
149 data Block m l = Block BlockId (ZTail m l)
151 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
153 data LGraph m l = LGraph { lg_entry :: BlockId
154 , lg_blocks :: BlockEnv (Block m l) }
155 -- Invariant: lg_entry is in domain( lg_blocks )
157 -- | And now the zipper. The focus is between the head and tail.
158 -- We cannot ever focus on an inter-block edge.
159 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
160 data FGraph m l = FGraph { fg_entry :: BlockId
161 , fg_focus :: ZBlock m l
162 , fg_others :: BlockEnv (Block m l) }
163 -- Invariant: the block represented by 'fg_focus' is *not*
164 -- in the map 'fg_others'
166 ---- Utility functions ---
168 blockId :: Block m l -> BlockId
169 zip :: ZBlock m l -> Block m l
170 unzip :: Block m l -> ZBlock m l
172 last :: ZBlock m l -> ZLast l
173 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
175 tailOfLast :: l -> ZTail m l
177 -- | Take a head and tail and go to beginning or end. The asymmetry
178 -- in the types and names is a bit unfortunate, but 'Block m l' is
179 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
181 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
182 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
184 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
185 -- For a head, we have a head 'h' followed by a LGraph 'g'.
186 -- The entry node of 'g' gets joined to 'h', forming the entry into
187 -- the new LGraph. The exit of 'g' becomes the new head.
188 -- For both arguments and results, the order of values is the order of
189 -- control flow: before splicing, the head flows into the LGraph; after
190 -- splicing, the LGraph flows into the head.
191 -- Splicing a tail is the dual operation.
192 -- (In order to maintain the order-means-control-flow convention, the
193 -- orders are reversed.)
195 -- For example, assume
197 -- grph = (M, [M: <stuff>,
199 -- N: y:=x; LastExit])
200 -- tail = [return (y,x)]
202 -- Then splice_head head grph
203 -- = ((L, [L: x:=0; goto M,
208 -- Then splice_tail grph tail
210 -- , (???, [<blocks>,
211 -- N: y:=x; return (y,x)])
213 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
214 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
215 splice_tail :: Graph m l -> ZTail m l -> Graph m l
217 -- | We can also splice a single-entry, no-exit Graph into a head.
218 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
219 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
222 -- | A safe operation
224 -- | Conversion to and from the environment form is convenient. For
225 -- layout or dataflow, however, one will want to use 'postorder_dfs'
226 -- in order to get the blocks in an order that relates to the control
227 -- flow in the procedure.
228 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
229 to_block_list :: LGraph m l -> [Block m l] -- N log N
231 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
232 -- from the entry node. This list has the following property:
234 -- Say a "back reference" exists if one of a block's
235 -- control-flow successors precedes it in the output list
237 -- Then there are as few back references as possible
239 -- The output is suitable for use in
240 -- a forward dataflow problem. For a backward problem, simply reverse
241 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
242 -- one doesn't want to try and maintain both forward and backward
245 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
247 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
248 -- in layout order. The 'Maybe BlockId', if present, identifies the
249 -- block that will be the layout successor of the current block. This
250 -- may be useful to help an emitter omit the final 'goto' of a block
251 -- that flows directly to its layout successor.
253 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
254 -- = z <$> f (L1:B1) (Just L2)
255 -- <$> f (L2:B2) (Just L3)
256 -- <$> f (L3:B3) Nothing
257 -- where a <$> f = f a
259 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
261 -- | We can also fold over blocks in an unspecified order. The
262 -- 'ZipCfgExtras' module provides a monadic version, which we
263 -- haven't needed (else it would be here).
264 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
266 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
267 -- mapping includes the entry id!
269 map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
271 -- | These translation functions are speculative. I hope eventually
272 -- they will be used in the native-code back ends ---NR
273 translate :: Monad tm =>
274 (m -> tm (LGraph m' l')) ->
275 (l -> tm (LGraph m' l')) ->
276 (LGraph m l -> tm (LGraph m' l'))
279 -- | It's possible that another form of translation would be more suitable:
280 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
283 ------------------- Last nodes
285 -- | We can't make a graph out of just any old 'last node' type. A last node
286 -- has to be able to find its successors, and we need to be able to create and
287 -- identify unconditional branches. We put these capabilities in a type class.
288 -- Moreover, the property of having successors is also shared by 'Block's and
289 -- 'ZTails', so it is useful to have that property in a type class of its own.
291 class HavingSuccessors b where
292 succs :: b -> [BlockId]
293 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
295 fold_succs add l z = foldr add z $ succs l
297 class HavingSuccessors l => LastNode l where
298 mkBranchNode :: BlockId -> l
299 isBranchNode :: l -> Bool
300 branchNodeTarget :: l -> BlockId -- panics if not branch node
301 -- ^ N.B. This interface seems to make for more congenial clients than a
302 -- single function of type 'l -> Maybe BlockId'
304 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
306 succs (LastOther l) = succs l
307 fold_succs _ LastExit z = z
308 fold_succs f (LastOther l) z = fold_succs f l z
310 instance LastNode l => LastNode (ZLast l) where
311 mkBranchNode id = LastOther $ mkBranchNode id
312 isBranchNode LastExit = False
313 isBranchNode (LastOther l) = isBranchNode l
314 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
315 branchNodeTarget (LastOther l) = branchNodeTarget l
317 instance LastNode l => HavingSuccessors (ZBlock m l) where
318 succs b = succs (last b)
320 instance LastNode l => HavingSuccessors (Block m l) where
321 succs b = succs (unzip b)
323 instance LastNode l => HavingSuccessors (ZTail m l) where
324 succs b = succs (lastTail b)
328 -- ================ IMPLEMENTATION ================--
330 ----- block manipulations
332 blockId (Block id _) = id
334 -- | Convert block between forms.
335 -- These functions are tail-recursive, so we can go as deep as we like
336 -- without fear of stack overflow.
338 ht_to_block head tail = case head of
339 ZFirst id -> Block id tail
340 ZHead h m -> ht_to_block h (ZTail m tail)
342 ht_to_last head (ZLast l) = (head, l)
343 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
345 zipht h t = ht_to_block h t
346 zip (ZBlock h t) = ht_to_block h t
347 goto_end (ZBlock h t) = ht_to_last h t
349 unzip (Block id t) = ZBlock (ZFirst id) t
351 head_id :: ZHead m -> BlockId
352 head_id (ZFirst id) = id
353 head_id (ZHead h _) = head_id h
355 last (ZBlock _ t) = lastTail t
357 lastTail :: ZTail m l -> ZLast l
358 lastTail (ZLast l) = l
359 lastTail (ZTail _ t) = lastTail t
361 tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client
364 ------------------ simple graph manipulations
366 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
367 focus id (LGraph entry blocks) =
368 case lookupBlockEnv blocks id of
369 Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
370 Nothing -> panic "asked for nonexistent block in flow graph"
372 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
373 entry g@(LGraph eid _) = focus eid g
375 -- | pull out a block satisfying the predicate, if any
376 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
377 Maybe (Block m l, BlockEnv (Block m l))
378 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
379 where scan b (yes, no) =
381 Nothing | p b -> (Just b, no)
382 | otherwise -> (yes, insertBlock b no)
383 Just _ -> (yes, insertBlock b no)
384 lift (Nothing, _) = Nothing
385 lift (Just b, bs) = Just (b, bs)
387 -- | 'insertBlock' should not be used to *replace* an existing block
388 -- but only to insert a new one
389 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
391 ASSERT (isNothing $ lookupBlockEnv bs id)
392 extendBlockEnv bs id b
395 -- | Used in assertions; tells if a graph has exactly one exit
396 single_exit :: LGraph l m -> Bool
397 single_exit g = foldUFM check 0 (lg_blocks g) == 1
398 where check block count = case last (unzip block) of
399 LastExit -> count + (1 :: Int)
402 -- | Used in assertions; tells if a graph has exactly one exit
403 single_exitg :: Graph l m -> Bool
404 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
405 where add block count = count + exit_count (last (unzip block))
406 exit_count LastExit = 1 :: Int
409 ------------------ graph traversals
411 -- | This is the most important traversal over this data structure. It drops
412 -- unreachable code and puts blocks in an order that is good for solving forward
413 -- dataflow problems quickly. The reverse order is good for solving backward
414 -- dataflow problems quickly. The forward order is also reasonably good for
415 -- emitting instructions, except that it will not usually exploit Forrest
416 -- Baskett's trick of eliminating the unconditional branch from a loop. For
417 -- that you would need a more serious analysis, probably based on dominators, to
418 -- identify loop headers.
420 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
421 -- representation, when for most purposes the plain 'Graph' representation is
422 -- more mathematically elegant (but results in more complicated code).
424 -- Here's an easy way to go wrong! Consider
428 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
429 -- Better to geot [A,B,C,D]
432 postorder_dfs g@(LGraph _ blockenv) =
433 let FGraph id eblock _ = entry g in
434 zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
436 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
437 => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
438 postorder_dfs_from_except blocks b visited =
439 vchildren (get_children b) (\acc _visited -> acc) [] visited
442 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
443 vnode block@(Block id _) cont acc visited =
444 if elemBlockSet id visited then
447 let cont' acc visited = cont (block:acc) visited in
448 vchildren (get_children block) cont' acc (extendBlockSet visited id)
449 vchildren bs cont acc visited =
450 let next children acc visited =
451 case children of [] -> cont acc visited
452 (b:bs) -> vnode b (next bs) acc visited
453 in next bs acc visited
454 get_children block = foldl add_id [] (succs block)
455 add_id rst id = case lookupBlockEnv blocks id of
460 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
461 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
465 -- | Slightly more complicated than the usual fold because we want to tell block
466 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
467 -- 'goto b2', the goto can be omitted.
469 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
470 where fold blocks z =
471 case blocks of [] -> z
473 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
474 nextlabel (Block id _) =
475 if id == eid then panic "entry as successor"
478 -- | The rest of the traversals are straightforward
480 map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)
482 map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
483 where block (Block id t) = Block (idm id) (tail t)
484 tail (ZTail m t) = ZTail (middle m) (tail t)
485 tail (ZLast LastExit) = ZLast LastExit
486 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
488 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
490 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
491 to_block_list (LGraph _ blocks) = eltsUFM blocks
496 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
497 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
498 -- or it isn't. We use continuation-passing style.
500 prepare_for_splicing ::
501 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
503 prepare_for_splicing g single multi =
504 let FGraph _ gentry gblocks = entry g
505 ZBlock _ etail = gentry
506 in if isNullUFM gblocks then
508 LastExit -> single etail
509 _ -> panic "bad single block"
511 case splitp_blocks is_exit gblocks of
512 Nothing -> panic "Can't find an exit block"
513 Just (gexit, gblocks) ->
514 let (gh, gl) = goto_end $ unzip gexit in
515 case gl of LastExit -> multi etail gh gblocks
516 _ -> panic "exit is not exit?!"
518 prepare_for_splicing' ::
519 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
521 prepare_for_splicing' (Graph etail gblocks) single multi =
522 if isNullUFM gblocks then
523 case lastTail etail of
524 LastExit -> single etail
525 _ -> panic "bad single block"
527 case splitp_blocks is_exit gblocks of
528 Nothing -> panic "Can't find an exit block"
529 Just (gexit, gblocks) ->
530 let (gh, gl) = goto_end $ unzip gexit in
531 case gl of LastExit -> multi etail gh gblocks
532 _ -> panic "exit is not exit?!"
534 is_exit :: Block m l -> Bool
535 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
538 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
539 where eid = head_id head
540 splice_one_block tail' =
541 case ht_to_last head tail' of
542 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
543 _ -> panic "spliced LGraph without exit"
544 splice_many_blocks entry exit others =
545 (LGraph eid (insertBlock (zipht head entry) others), exit)
547 splice_head' head g =
548 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
549 where splice_one_block tail' =
550 case ht_to_last head tail' of
551 (head, LastExit) -> (emptyBlockEnv, head)
552 _ -> panic "spliced LGraph without exit"
553 splice_many_blocks entry exit others =
554 (insertBlock (zipht head entry) others, exit)
556 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
558 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
559 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
560 append_tails (ZLast LastExit) tail = tail
561 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
562 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
563 splice_many_blocks entry exit others =
564 Graph entry (insertBlock (zipht exit tail) others)
568 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
569 where splice_one_block tail' = -- return tail' .. tail
570 case ht_to_last (ZFirst (lg_entry g)) tail' of
572 case ht_to_block head' tail of
573 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
574 _ -> panic "entry in; garbage out"
575 _ -> panic "spliced single block without Exit"
576 splice_many_blocks entry exit others =
577 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
580 splice_head_only head g =
581 let FGraph eid gentry gblocks = entry g
583 ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
584 _ -> panic "entry not at start of block?!"
586 splice_head_only' head (Graph tail gblocks) =
587 let eblock = zipht head tail in
588 LGraph (blockId eblock) (insertBlock eblock gblocks)
593 translate txm txl (LGraph eid blocks) =
594 do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
595 return $ LGraph eid blocks'
598 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
599 txblock (Block id t) expanded =
600 do blocks' <- expanded
601 txtail (ZFirst id) t blocks'
602 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
603 -- tm (BlockEnv (Block m' l'))
604 txtail h (ZTail m t) blocks' =
606 let (g, h') = splice_head h m'
607 txtail h' t (plusUFM (lg_blocks g) blocks')
608 txtail h (ZLast (LastOther l)) blocks' =
610 return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
611 txtail h (ZLast LastExit) blocks' =
612 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
614 ----------------------------------------------------------------
615 --- Block Ids, their environments, and their sets
617 {- Note [Unique BlockId]
618 ~~~~~~~~~~~~~~~~~~~~~~~~
619 Although a 'BlockId' is a local label, for reasons of implementation,
620 'BlockId's must be unique within an entire compilation unit. The reason
621 is that each local label is mapped to an assembly-language label, and in
622 most assembly languages allow, a label is visible throughout the enitre
623 compilation unit in which it appears.
626 newtype BlockId = BlockId Unique
629 instance Uniquable BlockId where
630 getUnique (BlockId u) = u
632 instance Show BlockId where
633 show (BlockId u) = show u
635 instance Outputable BlockId where
636 ppr = ppr . getUnique
639 type BlockEnv a = UniqFM {- BlockId -} a
640 emptyBlockEnv :: BlockEnv a
641 emptyBlockEnv = emptyUFM
642 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
643 lookupBlockEnv = lookupUFM
644 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
645 extendBlockEnv = addToUFM
646 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
647 mkBlockEnv = listToUFM
649 type BlockSet = UniqSet BlockId
650 emptyBlockSet :: BlockSet
651 emptyBlockSet = emptyUniqSet
652 elemBlockSet :: BlockId -> BlockSet -> Bool
653 elemBlockSet = elementOfUniqSet
654 extendBlockSet :: BlockSet -> BlockId -> BlockSet
655 extendBlockSet = addOneToUniqSet
656 mkBlockSet :: [BlockId] -> BlockSet
657 mkBlockSet = mkUniqSet
659 ----------------------------------------------------------------
661 ----------------------------------------------------------------
663 -- putting this code in PprCmmZ leads to circular imports :-(
665 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
668 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
669 pprTail (ZTail m t) = ppr m $$ ppr t
670 pprTail (ZLast LastExit) = text "<exit>"
671 pprTail (ZLast (LastOther l)) = ppr l
673 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
674 pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
675 where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
676 blocks = postorder_dfs g
678 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
679 pprGraph (Graph tail blockenv) =
680 text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}"
681 where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
682 blocks = postorder_dfs_from blockenv tail
684 _unused :: FS.FastString