compiler/cmm/ZipCfg.hs

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