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