Fix Haddock errors.

[ghc-hetmet.git] / compiler / cmm / ZipCfg.hs

module ZipCfg
    (   -- These data types and names are carefully thought out
      Graph(..), LGraph(..), FGraph(..)
    , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
    , insertBlock
    , HavingSuccessors, succs, fold_succs
    , LastNode, mkBranchNode, isBranchNode, branchNodeTarget

        -- Observers and transformers
        -- (open to renaming suggestions here)
    , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
    , splice_tail, splice_head, splice_head_only', splice_head'
    , of_block_list, to_block_list
    , graphOfLGraph
    , map_blocks, map_nodes, mapM_blocks
    , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
    , fold_layout
    , fold_blocks, fold_fwd_block
    , translate

    , pprLgraph, pprGraph

    , entry -- exported for the convenience of ZipDataflow0, at least for now

    {-
    -- the following functions might one day be useful and can be found
    -- either below or in ZipCfgExtras:
    , entry, exit, focus, focusp, unfocus
    , ht_to_block, ht_to_last, 
    , splice_focus_entry, splice_focus_exit
    , foldM_fwd_block
    -}

    )
where

#include "HsVersions.h"

import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
               , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet)
import CmmExpr ( UserOfLocalRegs(..) ) --for an instance

import Outputable hiding (empty)
import Panic
import UniqFM
import UniqSet

import Maybe
import Prelude hiding (zip, unzip, last)

-------------------------------------------------------------------------
--               GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH               --
-------------------------------------------------------------------------
{-

This module defines datatypes used to represent control-flow graphs,
along with some functions for analyzing and splicing graphs.
Functions for building graphs are found in a separate module 'MkZipCfg'.

Every graph has a distinguished entry point.  A graph has at least one
exit; most exits are instructions (or statements) like 'jump' or
'return', which transfer control to other procedures, but a graph may
have up to one 'fall through' exit.  (A graph that represents an
entire Haskell or C-- procedure does not have a 'fall through' exit.)

A graph is a collection of basic blocks.  A basic block begins with a
label (unique id; see Note [Unique BlockId]) which is followed by a
sequence of zero or more 'middle' nodes; the basic block ends with a
'last' node.  Each 'middle' node is a single-entry, single-exit,
uninterruptible computation.  A 'last' node is a single-entry,
multiple-exit computation.  A last node may have zero or more successors,
which are identified by their unique ids.

A special case of last node is the ``default exit,'' which represents
'falling off the end' of the graph.  Such a node is always represented by
the data constructor 'LastExit'.  A graph may contain at most one
'LastExit' node, and a graph representing a full procedure should not
contain any 'LastExit' nodes.  'LastExit' nodes are used only to splice
graphs together, either during graph construction (see module 'MkZipCfg')
or during optimization (see module 'ZipDataflow0').

A graph is parameterized over the types of middle and last nodes.  Each of
these types will typically be instantiated with a subset of C-- statements
(see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
implemented as of August 2007).


Note [Kinds of Graphs]
~~~~~~~~~~~~~~~~~~~~~~
This module exposes three representations of graphs.  In order of
increasing complexity, they are:

  Graph  m l      The basic graph with its distinguished entry point

  LGraph m l      A graph with a *labelled* entry point

  FGraph m l      A labelled graph with the *focus* on a particular edge

There are three types because each type offers a slightly different
invariant or cost model.  

  * The distinguished entry of a Graph has no label.  Because labels must be
    unique, acquiring one requires a supply of Unique labels (BlockId's).
    The primary advantage of the Graph representation is that we can build a
    small Graph purely functionally, without needing a fresh BlockId or
    Unique.  For example, during optimization we can easily rewrite a single
    middle node into a Graph containing a sequence of two middle nodes
    followed by LastExit.

  * In an LGraph, every basic block is labelled.  The primary advantage of
    this representation is its simplicity: each basic block can be treated
    like any other.  This representation is used for mapping, folding, and
    translation, as well as layout.

    Like any graph, an LGraph still has a distinguished entry point, 
    which you can discover using 'lg_entry'.

  * An FGraph is an LGraph with the *focus* on one particular edge.  The
    primary advantage of this representation is that it provides
    constant-time access to the nodes connected by that edge, and it also
    allows constant-time, functional *replacement* of those nodes---in the
    style of Huet's 'zipper'.

None of these representations is ideally suited to the incremental
construction of large graphs.  A separate module, 'MkZipCfg', provides a
fourth representation that is asymptotically optimal for such construction.
    
-}

--------------- Representation --------------------

-- | A basic block is a 'first' node, followed by zero or more 'middle'
-- nodes, followed by a 'last' node.

-- eventually this module should probably replace the original Cmm, but for
-- now we leave it to dynamic invariants what can be found where

data ZLast l
  = LastExit     -- fall through; used for the block that has no last node
                 -- LastExit is a device used only for graphs under 
                 -- construction, or framgments of graph under optimisation,
                 -- so we don't want to pollute the 'l' type parameter with it
  | LastOther l

--So that we don't have orphan instances, this goes here or in CmmExpr.
--At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
--but there's no need for non-Haskell98 instances for that.
instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
    foldRegsUsed  f z (LastOther l) = foldRegsUsed f z l
    foldRegsUsed _f z LastExit      = z


data ZHead m   = ZFirst BlockId  | ZHead (ZHead m) m
    -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
    -- ZTail is a sequence of middle nodes followed by a last node

-- | Blocks and flow graphs; see Note [Kinds of graphs]
data Block m l = Block BlockId (ZTail m l)

data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }

data LGraph m l = LGraph  { lg_entry  :: BlockId
                          , lg_blocks :: BlockEnv (Block m l) }
        -- Invariant: lg_entry is in domain( lg_blocks )

-- | And now the zipper.  The focus is between the head and tail.
-- We cannot ever focus on an inter-block edge.
data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
data FGraph m l = FGraph { fg_entry  :: BlockId
                         , fg_focus  :: ZBlock m l
                         , fg_others :: BlockEnv (Block m l) }
                    -- Invariant: the block represented by 'fg_focus' is *not*
                    -- in the map 'fg_others'

----  Utility functions ---

blockId   :: Block  m l -> BlockId
zip       :: ZBlock m l -> Block  m l
unzip     :: Block  m l -> ZBlock m l

last      :: ZBlock m l -> ZLast l
goto_end  :: ZBlock m l -> (ZHead m, ZLast l)

tailOfLast :: l -> ZTail m l

-- | Take a head and tail and go to beginning or end.  The asymmetry
-- in the types and names is a bit unfortunate, but 'Block m l' is
-- effectively '(BlockId, ZTail m l)' and is accepted in many more places.

ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
ht_to_last         :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)

-- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
-- For a head, we have a head 'h' followed by a LGraph 'g'.
-- The entry node of 'g' gets joined to 'h', forming the entry into
-- the new LGraph.  The exit of 'g' becomes the new head.
-- For both arguments and results, the order of values is the order of
-- control flow: before splicing, the head flows into the LGraph; after
-- splicing, the LGraph flows into the head.
-- Splicing a tail is the dual operation.
-- (In order to maintain the order-means-control-flow convention, the
-- orders are reversed.)
--
-- For example, assume
--      head = [L: x:=0]
--      grph = (M, [M: <stuff>,
--                  <blocks>,
--                  N: y:=x; LastExit])
--      tail = [return (y,x)]
--
-- Then         splice_head head grph
--              = ((L, [L: x:=0; goto M,
--                      M: <stuff>,
--                      <blocks>])
--                 , N: y:=x)
--
-- Then         splice_tail grph tail
--              = ( <stuff>
--                , (???, [<blocks>,
--                         N: y:=x; return (y,x)])

splice_head  :: ZHead m    -> LGraph m l -> (LGraph m l, ZHead  m)
splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
splice_tail  :: Graph m l -> ZTail  m l -> Graph m l

-- | We can also splice a single-entry, no-exit Graph into a head.
splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
splice_head_only' :: ZHead m -> Graph m l -> LGraph m l


-- | A safe operation 

-- | Conversion to and from the environment form is convenient.  For
-- layout or dataflow, however, one will want to use 'postorder_dfs'
-- in order to get the blocks in an order that relates to the control
-- flow in the procedure.
of_block_list :: BlockId -> [Block m l] -> LGraph m l  -- N log N
to_block_list :: LGraph m l -> [Block m l]  -- N log N

-- | Conversion from LGraph to Graph
graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks


-- | Traversal: 'postorder_dfs' returns a list of blocks reachable
-- from the entry node.  This list has the following property:
--
--      Say a "back reference" exists if one of a block's
--      control-flow successors precedes it in the output list
--
--      Then there are as few back references as possible
--
-- The output is suitable for use in
-- a forward dataflow problem.  For a backward problem, simply reverse
-- the list.  ('postorder_dfs' is sufficiently tricky to implement that
-- one doesn't want to try and maintain both forward and backward
-- versions.)

postorder_dfs :: LastNode l => LGraph m l -> [Block m l]

-- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
-- in layout order.  The 'Maybe BlockId', if present, identifies the
-- block that will be the layout successor of the current block.  This
-- may be useful to help an emitter omit the final 'goto' of a block
-- that flows directly to its layout successor.
--
-- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
--              = z <$> f (L1:B1) (Just L2)
--                  <$> f (L2:B2) (Just L3)
--                  <$> f (L3:B3) Nothing
-- where a <$> f = f a
fold_layout ::
    LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a

-- | We can also fold over blocks in an unspecified order.  The
-- 'ZipCfgExtras' module provides a monadic version, which we
-- haven't needed (else it would be here).
fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a

-- | Fold from first to last
fold_fwd_block ::
  (BlockId -> a -> a) -> (m -> a -> a) -> (ZLast l -> a -> a) -> Block m l -> a -> a

map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
   -- mapping includes the entry id!

map_blocks  :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
mapM_blocks :: Monad mm
            => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')

-- | These translation functions are speculative.  I hope eventually
-- they will be used in the native-code back ends ---NR
translate :: Monad tm =>
             (m          -> tm (LGraph m' l')) ->
             (l          -> tm (LGraph m' l')) ->
             (LGraph m l -> tm (LGraph m' l'))

{-
-- | It's possible that another form of translation would be more suitable:
translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
-}

------------------- Last nodes

-- | We can't make a graph out of just any old 'last node' type.  A last node
-- has to be able to find its successors, and we need to be able to create and
-- identify unconditional branches.  We put these capabilities in a type class.
-- Moreover, the property of having successors is also shared by 'Block's and
-- 'ZTails', so it is useful to have that property in a type class of its own.

class HavingSuccessors b where
    succs :: b -> [BlockId]
    fold_succs :: (BlockId -> a -> a) -> b -> a -> a

    fold_succs add l z = foldr add z $ succs l

class HavingSuccessors l => LastNode l where
    mkBranchNode     :: BlockId -> l
    isBranchNode     :: l -> Bool
    branchNodeTarget :: l -> BlockId  -- panics if not branch node
      -- ^ N.B. This interface seems to make for more congenial clients than a
      -- single function of type 'l -> Maybe BlockId'

instance HavingSuccessors l => HavingSuccessors (ZLast l) where
    succs LastExit = []
    succs (LastOther l) = succs l
    fold_succs _ LastExit z = z
    fold_succs f (LastOther l) z = fold_succs f l z

instance LastNode l => LastNode (ZLast l) where
    mkBranchNode id = LastOther $ mkBranchNode id
    isBranchNode LastExit = False
    isBranchNode (LastOther l) = isBranchNode l
    branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
    branchNodeTarget (LastOther l) = branchNodeTarget l

instance LastNode l => HavingSuccessors (ZBlock m l) where
    succs b = succs (last b)

instance LastNode l => HavingSuccessors (Block m l) where
    succs b = succs (unzip b)

instance LastNode l => HavingSuccessors (ZTail m l) where
    succs b = succs (lastTail b)



-- ================ IMPLEMENTATION ================--

----- block manipulations

blockId (Block id _) = id

-- | Convert block between forms.
-- These functions are tail-recursive, so we can go as deep as we like
-- without fear of stack overflow.  

ht_to_block head tail = case head of
  ZFirst id -> Block id tail
  ZHead h m -> ht_to_block h (ZTail m tail) 

ht_to_last head (ZLast l)   = (head, l)
ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t 

zipht            h t  = ht_to_block h t
zip      (ZBlock h t) = ht_to_block h t
goto_end (ZBlock h t) = ht_to_last  h t

unzip (Block id t) = ZBlock (ZFirst id) t

head_id :: ZHead m -> BlockId
head_id (ZFirst id) = id
head_id (ZHead h _) = head_id h

last (ZBlock _ t) = lastTail t

lastTail :: ZTail m l -> ZLast l
lastTail (ZLast l) = l
lastTail (ZTail _ t) = lastTail t

tailOfLast l = ZLast (LastOther l) -- tedious to write in every client


------------------ simple graph manipulations

focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id 
focus id (LGraph entry blocks) =
    case lookupBlockEnv blocks id of
      Just b -> FGraph entry (unzip b) (delFromUFM blocks id)
      Nothing -> panic "asked for nonexistent block in flow graph"

entry   :: LGraph m l -> FGraph m l         -- focus on edge out of entry node 
entry g@(LGraph eid _) = focus eid g

-- | pull out a block satisfying the predicate, if any
splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
                 Maybe (Block m l, BlockEnv (Block m l))
splitp_blocks p blocks = lift $ foldUFM scan (Nothing, emptyBlockEnv) blocks 
    where scan b (yes, no) =
              case yes of
                Nothing | p b -> (Just b, no)
                        | otherwise -> (yes, insertBlock b no)
                Just _ -> (yes, insertBlock b no)
          lift (Nothing, _) = Nothing
          lift (Just b, bs) = Just (b, bs)

-- | 'insertBlock' should not be used to *replace* an existing block
-- but only to insert a new one
insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
insertBlock b bs =
      ASSERT (isNothing $ lookupBlockEnv bs id)
      extendBlockEnv bs id b
    where id = blockId b

-- | Used in assertions; tells if a graph has exactly one exit
single_exit :: LGraph l m -> Bool
single_exit g = foldUFM check 0 (lg_blocks g) == 1
    where check block count = case last (unzip block) of
                                LastExit -> count + (1 :: Int)
                                _ -> count

-- | Used in assertions; tells if a graph has exactly one exit
single_exitg :: Graph l m -> Bool
single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) blocks == 1
    where add block count = count + exit_count (last (unzip block))
          exit_count LastExit = 1 :: Int
          exit_count _        = 0

------------------ graph traversals

-- | This is the most important traversal over this data structure.  It drops
-- unreachable code and puts blocks in an order that is good for solving forward
-- dataflow problems quickly.  The reverse order is good for solving backward
-- dataflow problems quickly.  The forward order is also reasonably good for
-- emitting instructions, except that it will not usually exploit Forrest
-- Baskett's trick of eliminating the unconditional branch from a loop.  For
-- that you would need a more serious analysis, probably based on dominators, to
-- identify loop headers.
--
-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
-- representation, when for most purposes the plain 'Graph' representation is
-- more mathematically elegant (but results in more complicated code).
--
-- Here's an easy way to go wrong!  Consider
-- @
--      A -> [B,C]
--      B -> D
--      C -> D
-- @
-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
-- Better to geot [A,B,C,D]


postorder_dfs g@(LGraph _ blockenv) =
    let FGraph id eblock _ = entry g in
     zip eblock : postorder_dfs_from_except blockenv eblock (unitUniqSet id)

postorder_dfs_from_except :: (HavingSuccessors b, LastNode l)
                          => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
postorder_dfs_from_except blocks b visited =
  vchildren (get_children b) (\acc _visited -> acc) [] visited
  where
    -- vnode ::
    --    Block m l -> ([Block m l] -> BlockSet -> a) -> [Block m l] -> BlockSet -> a
    vnode block@(Block id _) cont acc visited =
        if elemBlockSet id visited then
            cont acc visited
        else
            let cont' acc visited = cont (block:acc) visited in
            vchildren (get_children block) cont' acc (extendBlockSet visited id)
    vchildren bs cont acc visited =
        let next children acc visited =
                case children of []     -> cont acc visited
                                 (b:bs) -> vnode b (next bs) acc visited
        in next bs acc visited
    get_children block = foldl add_id [] (succs block)
    add_id rst id = case lookupBlockEnv blocks id of
                      Just b -> b : rst
                      Nothing -> rst

postorder_dfs_from
    :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet



-- | Slightly more complicated than the usual fold because we want to tell block
-- 'b1' what its inline successor is going to be, so that if 'b1' ends with
-- 'goto b2', the goto can be omitted.

fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
  where fold blocks z =
            case blocks of [] -> z
                           [b] -> f b Nothing z
                           b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
        nextlabel (Block id _) =
            if id == eid then panic "entry as successor"
            else Just id

-- | The rest of the traversals are straightforward

map_blocks f (LGraph eid blocks) = LGraph eid (mapUFM f blocks)

map_nodes idm middle last (LGraph eid blocks) = LGraph (idm eid) (mapUFM block blocks)
    where block (Block id t) = Block (idm id) (tail t)
          tail (ZTail m t) = ZTail (middle m) (tail t)
          tail (ZLast LastExit) = ZLast LastExit
          tail (ZLast (LastOther l)) = ZLast (LastOther (last l))


mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid 
    where blocks' =
            foldUFM (\b mblocks -> do { blocks <- mblocks
                                      ; b <- f b
                                      ; return $ insertBlock b blocks })
                    (return emptyBlockEnv) blocks

fold_blocks f z (LGraph _ blocks) = foldUFM f z blocks
fold_fwd_block first middle last (Block id t) z = tail t (first id z)
    where tail (ZTail m t) z = tail t (middle m z)
          tail (ZLast l)   z = last l z

of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks 
to_block_list (LGraph _ blocks) = eltsUFM blocks




-- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
-- splicing purposes.  There are two useful cases: the 'LGraph' is a single block
-- or it isn't.  We use continuation-passing style.

prepare_for_splicing ::
  LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
  -> a
prepare_for_splicing g single multi =
  let FGraph _ gentry gblocks = entry g 
      ZBlock _ etail = gentry
  in if isNullUFM gblocks then
         case last gentry of
           LastExit -> single etail
           _ -> panic "bad single block"
     else
       case splitp_blocks is_exit gblocks of
         Nothing -> panic "Can't find an exit block"
         Just (gexit, gblocks) ->
              let (gh, gl) = goto_end $ unzip gexit in
              case gl of LastExit -> multi etail gh gblocks
                         _ -> panic "exit is not exit?!"

prepare_for_splicing' ::
  Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
  -> a
prepare_for_splicing' (Graph etail gblocks) single multi =
   if isNullUFM gblocks then
       case lastTail etail of
         LastExit -> single etail
         _ -> panic "bad single block"
   else
     case splitp_blocks is_exit gblocks of
       Nothing -> panic "Can't find an exit block"
       Just (gexit, gblocks) ->
            let (gh, gl) = goto_end $ unzip gexit in
            case gl of LastExit -> multi etail gh gblocks
                       _ -> panic "exit is not exit?!"

is_exit :: Block m l -> Bool
is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }

splice_head head g = 
  ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
   where eid = head_id head
         splice_one_block tail' =
             case ht_to_last head tail' of
               (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
               _ -> panic "spliced LGraph without exit" 
         splice_many_blocks entry exit others =
             (LGraph eid (insertBlock (zipht head entry) others), exit)

splice_head' head g = 
  ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
   where splice_one_block tail' = 
             case ht_to_last head tail' of
               (head, LastExit) -> (emptyBlockEnv, head)
               _ -> panic "spliced LGraph without exit" 
         splice_many_blocks entry exit others =
             (insertBlock (zipht head entry) others, exit)

-- splice_tail :: Graph m l -> ZTail m l -> Graph m l
splice_tail g tail =
  ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
    where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
          append_tails (ZLast LastExit) tail = tail
          append_tails (ZLast _) _ = panic "spliced single block without LastExit"
          append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
          splice_many_blocks entry exit others =
              Graph entry (insertBlock (zipht exit tail) others)

{-
splice_tail g tail =
  AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
    where splice_one_block tail' =  -- return tail' .. tail 
            case ht_to_last (ZFirst (lg_entry g)) tail' of
              (head', LastExit) ->
                  case ht_to_block head' tail of
                     Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
                     _ -> panic "entry in; garbage out"
              _ -> panic "spliced single block without Exit" 
          splice_many_blocks entry exit others =
              (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
-}

splice_head_only head g =
  let FGraph eid gentry gblocks = entry g
  in case gentry of
       ZBlock (ZFirst _) tail -> LGraph eid (insertBlock (zipht head tail) gblocks)
       _ -> panic "entry not at start of block?!"

splice_head_only' head (Graph tail gblocks) =
  let eblock = zipht head tail in
  LGraph (blockId eblock) (insertBlock eblock gblocks)


--- Translation

translate txm txl (LGraph eid blocks) =
    do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks
       return $ LGraph eid blocks'
    where
      -- txblock ::
      -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
      txblock (Block id t) expanded =
        do blocks' <- expanded
           txtail (ZFirst id) t blocks'
      -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
      --           tm (BlockEnv (Block m' l'))
      txtail h (ZTail m t) blocks' =
        do m' <- txm m 
           let (g, h') = splice_head h m' 
           txtail h' t (plusUFM (lg_blocks g) blocks')
      txtail h (ZLast (LastOther l)) blocks' =
        do l' <- txl l
           return $ plusUFM (lg_blocks (splice_head_only h l')) blocks'
      txtail h (ZLast LastExit) blocks' =
        return $ insertBlock (zipht h (ZLast LastExit)) blocks'

----------------------------------------------------------------
---- Prettyprinting
----------------------------------------------------------------

-- putting this code in PprCmmZ leads to circular imports :-(

instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
    ppr = pprTail

instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
    ppr = pprGraph

instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
    ppr = pprLgraph

instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
    ppr = pprBlock

instance (Outputable l) => Outputable (ZLast l) where
    ppr = pprLast

pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc 
pprTail (ZTail m t) = ppr m $$ ppr t
pprTail (ZLast l) = ppr l

pprLast :: (Outputable l) => ZLast l -> SDoc
pprLast LastExit = text "<exit>"
pprLast (LastOther l) = ppr l

pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
pprBlock (Block id tail) = ppr id <> colon $$ ppr tail

pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
pprLgraph g = text "{" $$ nest 2 (vcat $ map ppr blocks) $$ text "}"
    where blocks = postorder_dfs g

pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
pprGraph (Graph tail blockenv) =
        text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
    where blocks = postorder_dfs_from blockenv tail