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 Outputable hiding (empty)
  41 import Panic
  42 import Unique
  43 import UniqFM
  44 import UniqSet
  45
  46 import Maybe
  47 import Prelude hiding (zip, unzip, last)
  48
  49 -------------------------------------------------------------------------
  50 --               GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH               --
  51 -------------------------------------------------------------------------
  52 {-
  53
  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'.
  57
  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.)
  63
  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.
  71
  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 'ZipDataflow0').
  79
  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).
  84
  85
  86 Note [Kinds of Graphs]
  87 ~~~~~~~~~~~~~~~~~~~~~~
  88 This module exposes three representations of graphs.  In order of
  89 increasing complexity, they are:
  90
  91   Graph  m l      The basic graph with its distinguished entry point
  92
  93   LGraph m l      A graph with a *labelled* entry point
  94
  95   FGraph m l      A labelled graph with the *focus* on a particular edge
  96
  97 There are three types because each type offers a slightly different
  98 invariant or cost model.
  99
 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.
 107
 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.
 112
 113     Like any graph, an LGraph still has a distinguished entry point,
 114     which you can discover using 'lg_entry'.
 115
 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'.
 121
 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.
 125
 126 -}
 127
 128 --------------- Representation --------------------
 129
 130 -- | A basic block is a 'first' node, followed by zero or more 'middle'
 131 -- nodes, followed by a 'last' node.
 132
 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
 135
 136 data ZLast l
 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
 141   | LastOther l
 142
 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
 147
 148 -- | Blocks and flow graphs; see Note [Kinds of graphs]
 149 data Block m l = Block BlockId (ZTail m l)
 150
 151 data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
 152
 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 )
 156
 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'
 165
 166 ----  Utility functions ---
 167
 168 blockId   :: Block  m l -> BlockId
 169 zip       :: ZBlock m l -> Block  m l
 170 unzip     :: Block  m l -> ZBlock m l
 171
 172 last      :: ZBlock m l -> ZLast l
 173 goto_end  :: ZBlock m l -> (ZHead m, ZLast l)
 174
 175 tailOfLast :: l -> ZTail m l
 176
 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.
 180
 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)
 183
 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.)
 194 --
 195 -- For example, assume
 196 --      head = [L: x:=0]
 197 --      grph = (M, [M: <stuff>,
 198 --                  <blocks>,
 199 --                  N: y:=x; LastExit])
 200 --      tail = [return (y,x)]
 201 --
 202 -- Then         splice_head head grph
 203 --              = ((L, [L: x:=0; goto M,
 204 --                      M: <stuff>,
 205 --                      <blocks>])
 206 --                 , N: y:=x)
 207 --
 208 -- Then         splice_tail grph tail
 209 --              = ( <stuff>
 210 --                , (???, [<blocks>,
 211 --                         N: y:=x; return (y,x)])
 212
 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
 216
 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
 220
 221
 222 -- | A safe operation
 223
 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
 230
 231 -- | Traversal: 'postorder_dfs' returns a list of blocks reachable
 232 -- from the entry node.  This list has the following property:
 233 --
 234 --      Say a "back reference" exists if one of a block's
 235 --      control-flow successors precedes it in the output list
 236 --
 237 --      Then there are as few back references as possible
 238 --
 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
 243 -- versions.)
 244
 245 postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
 246
 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.
 252 --
 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
 258 fold_layout ::
 259     LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
 260
 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
 265
 266 map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
 267    -- mapping includes the entry id!
 268
 269 map_blocks  :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
 270 mapM_blocks :: Monad mm
 271             => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
 272
 273 -- | These translation functions are speculative.  I hope eventually
 274 -- they will be used in the native-code back ends ---NR
 275 translate :: Monad tm =>
 276              (m          -> tm (LGraph m' l')) ->
 277              (l          -> tm (LGraph m' l')) ->
 278              (LGraph m l -> tm (LGraph m' l'))
 279
 280 {-
 281 -- | It's possible that another form of translation would be more suitable:
 282 translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
 283 -}
 284
 285 ------------------- Last nodes
 286
 287 -- | We can't make a graph out of just any old 'last node' type.  A last node
 288 -- has to be able to find its successors, and we need to be able to create and
 289 -- identify unconditional branches.  We put these capabilities in a type class.
 290 -- Moreover, the property of having successors is also shared by 'Block's and
 291 -- 'ZTails', so it is useful to have that property in a type class of its own.
 292
 293 class HavingSuccessors b where
 294     succs :: b -> [BlockId]
 295     fold_succs :: (BlockId -> a -> a) -> b -> a -> a
 296
 297     fold_succs add l z = foldr add z $ succs l
 298
 299 class HavingSuccessors l => LastNode l where
 300     mkBranchNode     :: BlockId -> l
 301     isBranchNode     :: l -> Bool
 302     branchNodeTarget :: l -> BlockId  -- panics if not branch node
 303       -- ^ N.B. This interface seems to make for more congenial clients than a
 304       -- single function of type 'l -> Maybe BlockId'
 305
 306 instance HavingSuccessors l => HavingSuccessors (ZLast l) where
 307     succs LastExit = []
 308     succs (LastOther l) = succs l
 309     fold_succs _ LastExit z = z
 310     fold_succs f (LastOther l) z = fold_succs f l z
 311
 312 instance LastNode l => LastNode (ZLast l) where
 313     mkBranchNode id = LastOther $ mkBranchNode id
 314     isBranchNode LastExit = False
 315     isBranchNode (LastOther l) = isBranchNode l
 316     branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
 317     branchNodeTarget (LastOther l) = branchNodeTarget l
 318
 319 instance LastNode l => HavingSuccessors (ZBlock m l) where
 320     succs b = succs (last b)
 321
 322 instance LastNode l => HavingSuccessors (Block m l) where
 323     succs b = succs (unzip b)
 324
 325 instance LastNode l => HavingSuccessors (ZTail m l) where
 326     succs b = succs (lastTail b)
 327
 328
 329
 330 -- ================ IMPLEMENTATION ================--
 331
 332 ----- block manipulations
 333
 334 blockId (Block id _) = id
 335
 336 -- | Convert block between forms.
 337 -- These functions are tail-recursive, so we can go as deep as we like
 338 -- without fear of stack overflow.
 339
 340 ht_to_block head tail = case head of
 341   ZFirst id -> Block id tail
 342   ZHead h m -> ht_to_block h (ZTail m tail)
 343
 344 ht_to_last head (ZLast l)   = (head, l)
 345 ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
 346
 347 zipht            h t  = ht_to_block h t
 348 zip      (ZBlock h t) = ht_to_block h t
 349 goto_end (ZBlock h t) = ht_to_last  h t
 350
 351 unzip (Block id t) = ZBlock (ZFirst id) t
 352
 353 head_id :: ZHead m -> BlockId
 354 head_id (ZFirst id) = id
 355 head_id (ZHead h _) = head_id h
 356
 357 last (ZBlock _ t) = lastTail t
 358
 359 lastTail :: ZTail m l -> ZLast l
 360 lastTail (ZLast l) = l
 361 lastTail (ZTail _ t) = lastTail t
 362
 363 tailOfLast l = ZLast (LastOther l) -- ^ tedious to write in every client
 364
 365
 366 ------------------ simple graph manipulations
 367
 368 focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
 369 focus id (LGraph entry blocks) =
 370     case lookupBlockEnv blocks id of
 371       Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
 372       Nothing -> panic "asked for nonexistent block in flow graph"
 373
 374 entry   :: LGraph m l -> FGraph m l         -- focus on edge out of entry node
 375 entry g@(LGraph eid _) = focus eid g
 376
 377 -- | pull out a block satisfying the predicate, if any
 378 splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
 379                  Maybe (Block m l, BlockEnv (Block m l))
 380 splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks
 381     where scan b (yes, no) =
 382               case yes of
 383                 Nothing | p b -> (Just b, no)
 384                         | otherwise -> (yes, insertBlock b no)
 385                 Just _ -> (yes, insertBlock b no)
 386           lift (Nothing, _) = Nothing
 387           lift (Just b, bs) = Just (b, bs)
 388
 389 -- | 'insertBlock' should not be used to *replace* an existing block
 390 -- but only to insert a new one
 391 insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
 392 insertBlock b bs =
 393       ASSERT (isNothing $ lookupBlockEnv bs id)
 394       extendBlockEnv bs id b
 395     where id = blockId b
 396
 397 -- | Used in assertions; tells if a graph has exactly one exit
 398 single_exit :: LGraph l m -> Bool
 399 single_exit g = foldUFM check 0 (lg_blocks g) == 1
 400     where check block count = case last (unzip block) of
 401                                 LastExit -> count + (1 :: Int)
 402                                 _ -> count
 403
 404 -- | Used in assertions; tells if a graph has exactly one exit
 405 single_exitg :: Graph l m -> Bool
 406 single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
 407     where add block count = count + exit_count (last (unzip block))
 408           exit_count LastExit = 1 :: Int
 409           exit_count _        = 0
 410
 411 ------------------ graph traversals
 412
 413 -- | This is the most important traversal over this data structure.  It drops
 414 -- unreachable code and puts blocks in an order that is good for solving forward
 415 -- dataflow problems quickly.  The reverse order is good for solving backward
 416 -- dataflow problems quickly.  The forward order is also reasonably good for
 417 -- emitting instructions, except that it will not usually exploit Forrest
 418 -- Baskett's trick of eliminating the unconditional branch from a loop.  For
 419 -- that you would need a more serious analysis, probably based on dominators, to
 420 -- identify loop headers.
 421 --
 422 -- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
 423 -- representation, when for most purposes the plain 'Graph' representation is
 424 -- more mathematically elegant (but results in more complicated code).
 425 --
 426 -- Here's an easy way to go wrong!  Consider
 427 --      A -> [B,C]
 428 --      B -> D
 429 --      C -> D
 430 -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
 431 -- Better to geot [A,B,C,D]
 432
 433
 434 postorder_dfs g@(LGraph _ blockenv) =
 435     let FGraph id eblock _ = entry g in
 436      zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)
 437
 438 postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
 439                           => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
 440 postorder_dfs_from_except blocks b visited =
 441   vchildren (get_children b) (\acc _visited -> acc) [] visited
 442   where
 443     -- vnode ::
 444     --    Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
 445     vnode block@(Block id _) cont acc visited =
 446         if elemBlockSet id visited then
 447             cont acc visited
 448         else
 449             let cont' acc visited = cont (block:acc) visited in
 450             vchildren (get_children block) cont' acc (extendBlockSet visited id)
 451     vchildren bs cont acc visited =
 452         let next children acc visited =
 453                 case children of []     -> cont 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
 458                       Just b -> b : rst
 459                       Nothing -> rst
 460
 461 postorder_dfs_from
 462     :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
 463 postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
 464
 465
 466
 467 -- | Slightly more complicated than the usual fold because we want to tell block
 468 -- 'b1' what its inline successor is going to be, so that if 'b1' ends with
 469 -- 'goto b2', the goto can be omitted.
 470
 471 fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
 472   where fold blocks z =
 473             case blocks of [] -> z
 474                            [b] -> f b Nothing z
 475                            b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
 476         nextlabel (Block id _) =
 477             if id == eid then panic "entry as successor"
 478             else Just id
 479
 480 -- | The rest of the traversals are straightforward
 481
 482 map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)
 483
 484 map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
 485     where block (Block id t) = Block (idm id) (tail t)
 486           tail (ZTail m t) = ZTail (middle m) (tail t)
 487           tail (ZLast LastExit) = ZLast LastExit
 488           tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
 489
 490
 491 mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
 492     where blocks' =
 493             foldUFM (\b mblocks -> do { blocks <- mblocks
 494                                       ; b <- f b
 495                                       ; return $ insertBlock b blocks })
 496                     (return emptyBlockEnv) blocks
 497
 498 fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
 499
 500 of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
 501 to_block_list (LGraph _ blocks) = eltsUFM blocks
 502
 503
 504
 505
 506 -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
 507 -- splicing purposes.  There are two useful cases: the 'LGraph' is a single block
 508 -- or it isn't.  We use continuation-passing style.
 509
 510 prepare_for_splicing ::
 511   LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
 512   -> a
 513 prepare_for_splicing g single multi =
 514   let FGraph _ gentry gblocks = entry g
 515       ZBlock _ etail = gentry
 516   in if isNullUFM gblocks then
 517          case last gentry of
 518            LastExit -> single etail
 519            _ -> panic "bad single block"
 520      else
 521        case splitp_blocks is_exit gblocks of
 522          Nothing -> panic "Can't find an exit block"
 523          Just (gexit, gblocks) ->
 524               let (gh, gl) = goto_end $ unzip gexit in
 525               case gl of LastExit -> multi etail gh gblocks
 526                          _ -> panic "exit is not exit?!"
 527
 528 prepare_for_splicing' ::
 529   Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
 530   -> a
 531 prepare_for_splicing' (Graph etail gblocks) single multi =
 532    if isNullUFM gblocks then
 533        case lastTail etail of
 534          LastExit -> single etail
 535          _ -> panic "bad single block"
 536    else
 537      case splitp_blocks is_exit gblocks of
 538        Nothing -> panic "Can't find an exit block"
 539        Just (gexit, gblocks) ->
 540             let (gh, gl) = goto_end $ unzip gexit in
 541             case gl of LastExit -> multi etail gh gblocks
 542                        _ -> panic "exit is not exit?!"
 543
 544 is_exit :: Block m l -> Bool
 545 is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
 546
 547 splice_head head g =
 548   ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
 549    where eid = head_id head
 550          splice_one_block tail' =
 551              case ht_to_last head tail' of
 552                (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
 553                _ -> panic "spliced LGraph without exit"
 554          splice_many_blocks entry exit others =
 555              (LGraph eid (insertBlock (zipht head entry) others), exit)
 556
 557 splice_head' head g =
 558   ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
 559    where splice_one_block tail' =
 560              case ht_to_last head tail' of
 561                (head, LastExit) -> (emptyBlockEnv, head)
 562                _ -> panic "spliced LGraph without exit"
 563          splice_many_blocks entry exit others =
 564              (insertBlock (zipht head entry) others, exit)
 565
 566 -- splice_tail :: Graph m l -> ZTail m l -> Graph m l
 567 splice_tail g tail =
 568   ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
 569     where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
 570           append_tails (ZLast LastExit) tail = tail
 571           append_tails (ZLast _) _ = panic "spliced single block without LastExit"
 572           append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
 573           splice_many_blocks entry exit others =
 574               Graph entry (insertBlock (zipht exit tail) others)
 575
 576 {-
 577 splice_tail g tail =
 578   AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
 579     where splice_one_block tail' =  -- return tail' .. tail
 580             case ht_to_last (ZFirst (lg_entry g)) tail' of
 581               (head', LastExit) ->
 582                   case ht_to_block head' tail of
 583                      Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
 584                      _ -> panic "entry in; garbage out"
 585               _ -> panic "spliced single block without Exit"
 586           splice_many_blocks entry exit others =
 587               (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
 588 -}
 589
 590 splice_head_only head g =
 591   let FGraph eid gentry gblocks = entry g
 592   in case gentry of
 593        ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
 594        _ -> panic "entry not at start of block?!"
 595
 596 splice_head_only' head (Graph tail gblocks) =
 597   let eblock = zipht head tail in
 598   LGraph (blockId eblock) (insertBlock eblock gblocks)
 599
 600
 601 --- Translation
 602
 603 translate txm txl (LGraph eid blocks) =
 604     do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
 605        return $ LGraph eid blocks'
 606     where
 607       -- txblock ::
 608       -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
 609       txblock (Block id t) expanded =
 610         do blocks' <- expanded
 611            txtail (ZFirst id) t blocks'
 612       -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
 613       --           tm (BlockEnv (Block m' l'))
 614       txtail h (ZTail m t) blocks' =
 615         do m' <- txm m
 616            let (g, h') = splice_head h m'
 617            txtail h' t (plusUFM (lg_blocks g) blocks')
 618       txtail h (ZLast (LastOther l)) blocks' =
 619         do l' <- txl l
 620            return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
 621       txtail h (ZLast LastExit) blocks' =
 622         return $ insertBlock (zipht h (ZLast LastExit)) blocks'
 623
 624 ----------------------------------------------------------------
 625 --- Block Ids, their environments, and their sets
 626
 627 {- Note [Unique BlockId]
 628 ~~~~~~~~~~~~~~~~~~~~~~~~
 629 Although a 'BlockId' is a local label, for reasons of implementation,
 630 'BlockId's must be unique within an entire compilation unit.  The reason
 631 is that each local label is mapped to an assembly-language label, and in
 632 most assembly languages allow, a label is visible throughout the enitre
 633 compilation unit in which it appears.
 634 -}
 635
 636 newtype BlockId = BlockId Unique
 637   deriving (Eq,Ord)
 638
 639 instance Uniquable BlockId where
 640   getUnique (BlockId u) = u
 641
 642 mkBlockId :: Unique -> BlockId
 643 mkBlockId uniq = BlockId uniq
 644
 645 instance Show BlockId where
 646   show (BlockId u) = show u
 647
 648 instance Outputable BlockId where
 649   ppr = ppr . getUnique
 650
 651
 652 type BlockEnv a = UniqFM {- BlockId -} a
 653 emptyBlockEnv :: BlockEnv a
 654 emptyBlockEnv = emptyUFM
 655 lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
 656 lookupBlockEnv = lookupUFM
 657 extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
 658 extendBlockEnv = addToUFM
 659 mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
 660 mkBlockEnv = listToUFM
 661
 662 type BlockSet = UniqSet BlockId
 663 emptyBlockSet :: BlockSet
 664 emptyBlockSet = emptyUniqSet
 665 elemBlockSet :: BlockId -> BlockSet -> Bool
 666 elemBlockSet = elementOfUniqSet
 667 extendBlockSet :: BlockSet -> BlockId -> BlockSet
 668 extendBlockSet = addOneToUniqSet
 669 mkBlockSet :: [BlockId] -> BlockSet
 670 mkBlockSet = mkUniqSet
 671
 672 ----------------------------------------------------------------
 673 ---- Prettyprinting
 674 ----------------------------------------------------------------
 675
 676 -- putting this code in PprCmmZ leads to circular imports :-(
 677
 678 instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
 679     ppr = pprTail
 680
 681 pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
 682 pprTail (ZTail m t) = ppr m $$ ppr t
 683 pprTail (ZLast LastExit) = text "<exit>"
 684 pprTail (ZLast (LastOther l)) = ppr l
 685
 686 pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
 687 pprLgraph g = text "{" $$ nest 2 (vcat $ map pprBlock blocks) $$ text "}"
 688     where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
 689           blocks = postorder_dfs g
 690
 691 pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
 692 pprGraph (Graph tail blockenv) =
 693         text "{" $$ nest 2 (ppr tail $$ (vcat $ map pprBlock blocks)) $$ text "}"
 694     where pprBlock (Block id tail) = ppr id <> colon $$ ppr tail
 695           blocks = postorder_dfs_from blockenv tail
 696
 697 _unused :: FS.FastString
 698 _unused = undefined