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