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