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