compiler/cmm/ZipCfg.hs

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