compiler/cmm/ZipCfg.hs

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