compiler/cmm/ZipCfg.hs

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