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