1 {-# LANGUAGE ScopedTypeVariables #-}
3 ( -- These data types and names are carefully thought out
4 BlockId(..) -- ToDo: BlockId should be abstract, but it isn't yet
5 , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, insertBlock, mkBlockEnv
6 , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, mkBlockSet
7 , Graph(..), LGraph(..), FGraph(..)
8 , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
9 , HavingSuccessors, succs, fold_succs
10 , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
12 -- Observers and transformers
13 -- (open to renaming suggestions here)
14 , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
15 , splice_tail, splice_head, splice_head_only', splice_head'
16 , of_block_list, to_block_list
18 , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
25 , entry -- exported for the convenience of ZipDataflow, at least for now
28 -- the following functions might one day be useful and can be found
29 -- either below or in ZipCfgExtras:
30 , entry, exit, focus, focusp, unfocus
31 , ht_to_block, ht_to_last,
32 , splice_focus_entry, splice_focus_exit
33 , fold_fwd_block, foldM_fwd_block
39 #include "HsVersions.h"
41 import Outputable hiding (empty)
48 import Prelude hiding (zip, unzip, last)
50 -------------------------------------------------------------------------
51 -- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
52 -------------------------------------------------------------------------
55 This module defines datatypes used to represent control-flow graphs,
56 along with some functions for analyzing and splicing graphs.
57 Functions for building graphs are found in a separate module 'MkZipCfg'.
59 Every graph has a distinguished entry point. A graph has at least one
60 exit; most exits are instructions (or statements) like 'jump' or
61 'return', which transfer control to other procedures, but a graph may
62 have up to one 'fall through' exit. (A graph that represents an
63 entire Haskell or C-- procedure does not have a 'fall through' exit.)
65 A graph is a collection of basic blocks. A basic block begins with a
66 label (unique id; see Note [Unique BlockId]) which is followed by a
67 sequence of zero or more 'middle' nodes; the basic block ends with a
68 'last' node. Each 'middle' node is a single-entry, single-exit,
69 uninterruptible computation. A 'last' node is a single-entry,
70 multiple-exit computation. A last node may have zero or more successors,
71 which are identified by their unique ids.
73 A special case of last node is the ``default exit,'' which represents
74 'falling off the end' of the graph. Such a node is always represented by
75 the data constructor 'LastExit'. A graph may contain at most one
76 'LastExit' node, and a graph representing a full procedure should not
77 contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
78 graphs together, either during graph construction (see module 'MkZipCfg')
79 or during optimization (see module 'ZipDataflow').
81 A graph is parameterized over the types of middle and last nodes. Each of
82 these types will typically be instantiated with a subset of C-- statements
83 (see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
84 implemented as of August 2007).
87 Note [Kinds of Graphs]
88 ~~~~~~~~~~~~~~~~~~~~~~
89 This module exposes three representations of graphs. In order of
90 increasing complexity, they are:
92 Graph m l The basic graph with its distinguished entry point
94 LGraph m l A graph with a *labelled* entry point
96 FGraph m l A labelled graph with the *focus* on a particular edge
98 There are three types because each type offers a slightly different
99 invariant or cost model.
101 * The distinguished entry of a Graph has no label. Because labels must be
102 unique, acquiring one requires a supply of Unique labels (BlockId's).
103 The primary advantage of the Graph representation is that we can build a
104 small Graph purely functionally, without needing a fresh BlockId or
105 Unique. For example, during optimization we can easily rewrite a single
106 middle node into a Graph containing a sequence of two middle nodes
107 followed by LastExit.
109 * In an LGraph, every basic block is labelled. The primary advantage of
110 this representation is its simplicity: each basic block can be treated
111 like any other. This representation is used for mapping, folding, and
112 translation, as well as layout.
114 Like any graph, an LGraph still has a distinguished entry point,
115 which you can discover using 'lg_entry'.
117 * An FGraph is an LGraph with the *focus* on one particular edge. The
118 primary advantage of this representation is that it provides
119 constant-time access to the nodes connected by that edge, and it also
120 allows constant-time, functional *replacement* of those nodes---in the
121 style of Huet's 'zipper'.
123 None of these representations is ideally suited to the incremental
124 construction of large graphs. A separate module, 'MkZipCfg', provides a
125 fourth representation that is asymptotically optimal for such construction.
129 --------------- Representation --------------------
131 -- | A basic block is a 'first' node, followed by zero or more 'middle'
132 -- nodes, followed by a 'last' node.
134 -- eventually this module should probably replace the original Cmm, but for
135 -- now we leave it to dynamic invariants what can be found where
138 = LastExit -- fall through; used for the block that has no last node
139 -- LastExit is a device used only for graphs under
140 -- construction, or framgments of graph under optimisation,
141 -- so we don't want to pollute the 'l' type parameter with it
144 data ZHead m = ZFirst BlockId | ZHead (ZHead m) m
145 -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
146 data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
147 -- ZTail is a sequence of middle nodes followed by a last node
149 -- | Blocks and flow graphs; see Note [Kinds of graphs]
150 data Block m l = Block BlockId (ZTail m l)
152 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
154 data LGraph m l = LGraph { lg_entry :: BlockId
155 , lg_blocks :: BlockEnv (Block m l) }
156 -- Invariant: lg_entry is in domain( lg_blocks )
158 -- | And now the zipper. The focus is between the head and tail.
159 -- We cannot ever focus on an inter-block edge.
160 data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
161 data FGraph m l = FGraph { fg_entry :: BlockId
162 , fg_focus :: ZBlock m l
163 , fg_others :: BlockEnv (Block m l) }
164 -- Invariant: the block represented by 'fg_focus' is *not*
165 -- in the map 'fg_others'
167 ---- Utility functions ---
169 blockId :: Block m l -> BlockId
170 zip :: ZBlock m l -> Block m l
171 unzip :: Block m l -> ZBlock m l
173 last :: ZBlock m l -> ZLast l
174 goto_end :: ZBlock m l -> (ZHead m, ZLast l)
176 tailOfLast :: l -> ZTail m l
178 -- | Take a head and tail and go to beginning or end. The asymmetry
179 -- in the types and names is a bit unfortunate, but 'Block m l' is
180 -- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
182 ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
183 ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
185 -- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
186 -- For a head, we have a head 'h' followed by a LGraph 'g'.
187 -- The entry node of 'g' gets joined to 'h', forming the entry into
188 -- the new LGraph. The exit of 'g' becomes the new head.
189 -- For both arguments and results, the order of values is the order of
190 -- control flow: before splicing, the head flows into the LGraph; after
191 -- splicing, the LGraph flows into the head.
192 -- Splicing a tail is the dual operation.
193 -- (In order to maintain the order-means-control-flow convention, the
194 -- orders are reversed.)
196 -- For example, assume
198 -- grph = (M, [M: <stuff>,
200 -- N: y:=x; LastExit])
201 -- tail = [return (y,x)]
203 -- Then splice_head head grph
204 -- = ((L, [L: x:=0; goto M,
209 -- Then splice_tail grph tail
211 -- , (???, [<blocks>,
212 -- N: y:=x; return (y,x)])
214 splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
215 splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
216 splice_tail :: Graph m l -> ZTail m l -> Graph m l
218 -- | We can also splice a single-entry, no-exit Graph into a head.
219 splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
220 splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
223 -- | A safe operation
225 -- | Conversion to and from the environment form is convenient. For
226 -- layout or dataflow, however, one will want to use 'postorder_dfs'
227 -- in order to get the blocks in an order that relates to the control
228 -- flow in the procedure.
229 of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
230 to_block_list :: LGraph m l -> [Block m l] -- N log N
232 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
233 -- from the entry node. This list has the following property:
235 -- Say a "back reference" exists if one of a block's
236 -- control-flow successors precedes it in the output list
238 -- Then there are as few back references as possible
240 -- The output is suitable for use in
241 -- a forward dataflow problem. For a backward problem, simply reverse
242 -- the list. ('postorder_dfs' is sufficiently tricky to implement that
243 -- one doesn't want to try and maintain both forward and backward
246 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
248 -- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
249 -- in layout order. The 'Maybe BlockId', if present, identifies the
250 -- block that will be the layout successor of the current block. This
251 -- may be useful to help an emitter omit the final 'goto' of a block
252 -- that flows directly to its layout successor.
254 -- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
255 -- = z <$> f (L1:B1) (Just L2)
256 -- <$> f (L2:B2) (Just L3)
257 -- <$> f (L3:B3) Nothing
258 -- where a <$> f = f a
260 LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
262 -- | We can also fold over blocks in an unspecified order. The
263 -- 'ZipCfgExtras' module provides a monadic version, which we
264 -- haven't needed (else it would be here).
265 fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
267 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
268 -- mapping includes the entry id!
270 map_blocks :: (Block m l -> Block m' l') -> LGraph m' l' -> LGraph m' l'
272 -- | These translation functions are speculative. I hope eventually
273 -- they will be used in the native-code back ends ---NR
274 translate :: Monad tm =>
275 (m -> tm (LGraph m' l')) ->
276 (l -> tm (LGraph m' l')) ->
277 (LGraph m l -> tm (LGraph m' l'))
280 -- | It's possible that another form of translation would be more suitable:
281 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
284 ------------------- Last nodes
286 -- | We can't make a graph out of just any old 'last node' type. A last node
287 -- has to be able to find its successors, and we need to be able to create and
288 -- identify unconditional branches. We put these capabilities in a type class.
289 -- Moreover, the property of having successors is also shared by 'Block's and
290 -- 'ZTails', so it is useful to have that property in a type class of its own.
292 class HavingSuccessors b where
293 succs :: b -> [BlockId]
294 fold_succs :: (BlockId -> a -> a) -> b -> a -> a
296 fold_succs add l z = foldr add z $ succs l
298 class HavingSuccessors l => LastNode l where
299 mkBranchNode :: BlockId -> l
300 isBranchNode :: l -> Bool
301 branchNodeTarget :: l -> BlockId -- panics if not branch node
302 -- ^ N.B. This interface seems to make for more congenial clients than a
303 -- single function of type 'l -> Maybe BlockId'
305 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
307 succs (LastOther l) = succs l
308 fold_succs _ LastExit z = z
309 fold_succs f (LastOther l) z = fold_succs f l z
311 instance LastNode l => LastNode (ZLast l) where
312 mkBranchNode id = LastOther $ mkBranchNode id
313 isBranchNode LastExit = False
314 isBranchNode (LastOther l) = isBranchNode l
315 branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
316 branchNodeTarget (LastOther l) = branchNodeTarget l
318 instance LastNode l => HavingSuccessors (ZBlock m l) where
319 succs b = succs (last b)
321 instance LastNode l => HavingSuccessors (Block m l) where
322 succs b = succs (unzip b)
324 instance LastNode l => HavingSuccessors (ZTail m l) where
325 succs b = succs (lastTail b)
329 -- ================ IMPLEMENTATION ================--
331 ----- block manipulations
333 blockId (Block id _) = id
335 -- | Convert block between forms.
336 -- These functions are tail-recursive, so we can go as deep as we like
337 -- without fear of stack overflow.
339 ht_to_block head tail = case head of
340 ZFirst id -> Block id tail
341 ZHead h m -> ht_to_block h (ZTail m tail)
343 ht_to_last head (ZLast l) = (head, l)
344 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
346 zipht h t = ht_to_block h t
347 zip (ZBlock h t) = ht_to_block h t
348 goto_end (ZBlock h t) = ht_to_last h t
350 unzip (Block id t) = ZBlock (ZFirst id) t
352 head_id :: ZHead m -> BlockId
353 head_id (ZFirst id) = id
354 head_id (ZHead h _) = head_id h
356 last (ZBlock _ t) = lastTail t
358 lastTail :: ZTail m l -> ZLast l
359 lastTail (ZLast l) = l
360 lastTail (ZTail _ t) = lastTail t
362 tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client
365 ------------------ simple graph manipulations
367 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
368 focus id (LGraph entry blocks) =
369 case lookupBlockEnv blocks id of
370 Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
371 Nothing -> panic "asked for nonexistent block in flow graph"
373 entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
374 entry g@(LGraph eid _) = focus eid g
376 -- | pull out a block satisfying the predicate, if any
377 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
378 Maybe (Block m l, BlockEnv (Block m l))
379 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
380 where scan b (yes, no) =
382 Nothing | p b -> (Just b, no)
383 | otherwise -> (yes, insertBlock b no)
384 Just _ -> (yes, insertBlock b no)
385 lift (Nothing, _) = Nothing
386 lift (Just b, bs) = Just (b, bs)
388 -- | 'insertBlock' should not be used to *replace* an existing block
389 -- but only to insert a new one
390 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
392 ASSERT (isNothing $ lookupBlockEnv bs id)
393 extendBlockEnv bs id b
396 -- | Used in assertions; tells if a graph has exactly one exit
397 single_exit :: LGraph l m -> Bool
398 single_exit g = foldUFM check 0 (lg_blocks g) == 1
399 where check block count = case last (unzip block) of
400 LastExit -> count + (1 :: Int)
403 -- | Used in assertions; tells if a graph has exactly one exit
404 single_exitg :: Graph l m -> Bool
405 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
406 where add block count = count + exit_count (last (unzip block))
407 exit_count LastExit = 1 :: Int
410 ------------------ graph traversals
412 -- | This is the most important traversal over this data structure. It drops
413 -- unreachable code and puts blocks in an order that is good for solving forward
414 -- dataflow problems quickly. The reverse order is good for solving backward
415 -- dataflow problems quickly. The forward order is also reasonably good for
416 -- emitting instructions, except that it will not usually exploit Forrest
417 -- Baskett's trick of eliminating the unconditional branch from a loop. For
418 -- that you would need a more serious analysis, probably based on dominators, to
419 -- identify loop headers.
421 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
422 -- representation, when for most purposes the plain 'Graph' representation is
423 -- more mathematically elegant (but results in more complicated code).
425 -- Here's an easy way to go wrong! Consider
429 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
430 -- Better to geot [A,B,C,D]
433 postorder_dfs' :: LastNode l => LGraph m l -> [Block m l]
434 postorder_dfs' g@(LGraph _ blocks) =
435 let FGraph _ eblock _ = entry g
436 in vnode (zip eblock) (\acc _visited -> acc) [] emptyBlockSet
439 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
440 vnode block@(Block id _) cont acc visited =
441 if elemBlockSet id visited then
444 vchildren block (get_children block) cont acc (extendBlockSet visited id)
445 vchildren block bs cont acc visited =
446 let next children acc visited =
447 case children of [] -> cont (block : acc) visited
448 (b:bs) -> vnode b (next bs) acc visited
449 in next bs acc visited
450 get_children block = foldl add_id [] (succs block)
451 add_id rst id = case lookupBlockEnv blocks id of
455 postorder_dfs g@(LGraph _ blockenv) =
456 let FGraph id eblock _ = entry g
458 postorder_dfs_from_except blockenv eblock (unitUniqSet id)
459 dfs2 = postorder_dfs' g
460 -- in ASSERT (map blockId dfs1 == map blockId dfs2) dfs2
461 in if (map blockId dfs1 == map blockId dfs2) then dfs2 else panic "inconsistent DFS"
464 :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
465 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
467 postorder_dfs_from_except :: forall b m l . (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
468 postorder_dfs_from_except blocks b visited =
469 vchildren (get_children b) (\acc _visited -> acc) [] visited
472 -- Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
473 vnode block@(Block id _) cont acc visited =
474 if elemBlockSet id visited then
477 let cont' acc visited = cont (block:acc) visited in
478 vchildren (get_children block) cont' acc (extendBlockSet visited id)
479 vchildren bs cont acc visited =
480 let next children acc visited =
481 case children of [] -> cont acc visited
482 (b:bs) -> vnode b (next bs) acc visited
483 in next bs acc visited
484 get_children block = foldl add_id [] (succs block)
485 add_id rst id = case lookupBlockEnv blocks id of
490 -- | Slightly more complicated than the usual fold because we want to tell block
491 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
492 -- 'goto b2', the goto can be omitted.
494 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
495 where fold blocks z =
496 case blocks of [] -> z
498 b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
499 nextlabel (Block id _) =
500 if id == eid then panic "entry as successor"
503 -- | The rest of the traversals are straightforward
505 map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)
507 map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
508 where block (Block id t) = Block (idm id) (tail t)
509 tail (ZTail m t) = ZTail (middle m) (tail t)
510 tail (ZLast LastExit) = ZLast LastExit
511 tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
513 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
515 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
516 to_block_list (LGraph _ blocks) = eltsUFM blocks
521 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
522 -- splicing purposes. There are two useful cases: the 'LGraph' is a single block
523 -- or it isn't. We use continuation-passing style.
525 prepare_for_splicing ::
526 LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
528 prepare_for_splicing g single multi =
529 let FGraph _ gentry gblocks = entry g
530 ZBlock _ etail = gentry
531 in if isNullUFM gblocks then
533 LastExit -> single etail
534 _ -> panic "bad single block"
536 case splitp_blocks is_exit gblocks of
537 Nothing -> panic "Can't find an exit block"
538 Just (gexit, gblocks) ->
539 let (gh, gl) = goto_end $ unzip gexit in
540 case gl of LastExit -> multi etail gh gblocks
541 _ -> panic "exit is not exit?!"
543 prepare_for_splicing' ::
544 Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
546 prepare_for_splicing' (Graph etail gblocks) single multi =
547 if isNullUFM gblocks then
548 case lastTail etail of
549 LastExit -> single etail
550 _ -> panic "bad single block"
552 case splitp_blocks is_exit gblocks of
553 Nothing -> panic "Can't find an exit block"
554 Just (gexit, gblocks) ->
555 let (gh, gl) = goto_end $ unzip gexit in
556 case gl of LastExit -> multi etail gh gblocks
557 _ -> panic "exit is not exit?!"
559 is_exit :: Block m l -> Bool
560 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
563 ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
564 where eid = head_id head
565 splice_one_block tail' =
566 case ht_to_last head tail' of
567 (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
568 _ -> panic "spliced LGraph without exit"
569 splice_many_blocks entry exit others =
570 (LGraph eid (insertBlock (zipht head entry) others), exit)
572 splice_head' head g =
573 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
574 where splice_one_block tail' =
575 case ht_to_last head tail' of
576 (head, LastExit) -> (emptyBlockEnv, head)
577 _ -> panic "spliced LGraph without exit"
578 splice_many_blocks entry exit others =
579 (insertBlock (zipht head entry) others, exit)
581 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
583 ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
584 where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
585 append_tails (ZLast LastExit) tail = tail
586 append_tails (ZLast _) _ = panic "spliced single block without LastExit"
587 append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
588 splice_many_blocks entry exit others =
589 Graph entry (insertBlock (zipht exit tail) others)
593 AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
594 where splice_one_block tail' = -- return tail' .. tail
595 case ht_to_last (ZFirst (lg_entry g)) tail' of
597 case ht_to_block head' tail of
598 Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
599 _ -> panic "entry in; garbage out"
600 _ -> panic "spliced single block without Exit"
601 splice_many_blocks entry exit others =
602 (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
605 splice_head_only head g =
606 let FGraph eid gentry gblocks = entry g
608 ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
609 _ -> panic "entry not at start of block?!"
611 splice_head_only' head (Graph tail gblocks) =
612 let eblock = zipht head tail in
613 LGraph (blockId eblock) (insertBlock eblock gblocks)
618 translate txm txl (LGraph eid blocks) =
619 do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
620 return $ LGraph eid blocks'
623 -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
624 txblock (Block id t) expanded =
625 do blocks' <- expanded
626 txtail (ZFirst id) t blocks'
627 -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
628 -- tm (BlockEnv (Block m' l'))
629 txtail h (ZTail m t) blocks' =
631 let (g, h') = splice_head h m'
632 txtail h' t (plusUFM (lg_blocks g) blocks')
633 txtail h (ZLast (LastOther l)) blocks' =
635 return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
636 txtail h (ZLast LastExit) blocks' =
637 return $ insertBlock (zipht h (ZLast LastExit)) blocks'
639 ----------------------------------------------------------------
640 --- Block Ids, their environments, and their sets
642 {- Note [Unique BlockId]
643 ~~~~~~~~~~~~~~~~~~~~~~~~
644 Although a 'BlockId' is a local label, for reasons of implementation,
645 'BlockId's must be unique within an entire compilation unit. The reason
646 is that each local label is mapped to an assembly-language label, and in
647 most assembly languages allow, a label is visible throughout the enitre
648 compilation unit in which it appears.
651 newtype BlockId = BlockId Unique
654 instance Uniquable BlockId where
655 getUnique (BlockId u) = u
657 instance Show BlockId where
658 show (BlockId u) = show u
660 instance Outputable BlockId where
661 ppr = ppr . getUnique
664 type BlockEnv a = UniqFM {- BlockId -} a
665 emptyBlockEnv :: BlockEnv a
666 emptyBlockEnv = emptyUFM
667 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
668 lookupBlockEnv = lookupUFM
669 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
670 extendBlockEnv = addToUFM
671 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
672 mkBlockEnv = listToUFM
674 type BlockSet = UniqSet BlockId
675 emptyBlockSet :: BlockSet
676 emptyBlockSet = emptyUniqSet
677 elemBlockSet :: BlockId -> BlockSet -> Bool
678 elemBlockSet = elementOfUniqSet
679 extendBlockSet :: BlockSet -> BlockId -> BlockSet
680 extendBlockSet = addOneToUniqSet
681 mkBlockSet :: [BlockId] -> BlockSet
682 mkBlockSet = mkUniqSet
684 ----------------------------------------------------------------
686 ----------------------------------------------------------------
688 -- putting this code in PprCmmZ leads to circular imports :-(
690 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
693 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
694 pprTail (ZTail m t) = ppr m $$ ppr t
695 pprTail (ZLast LastExit) = text "<exit>"
696 pprTail (ZLast (LastOther l)) = ppr l
698 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
699 pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
700 where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
701 blocks = postorder_dfs g
703 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
704 pprGraph (Graph tail blockenv) =
705 text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}"
706 where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
707 blocks = postorder_dfs_from blockenv tail
709 _unused :: FS.FastString