Missing import in C-- parser

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

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index 4c35a92..af62168 100644 (file)
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
+

 
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what
 
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what

@@ -7,80 +7,106 @@
 
 module ZipCfgCmmRep
   ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
 
 module ZipCfgCmmRep
   ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)

+  , ValueDirection(..), CmmBackwardFixedPoint, CmmForwardFixedPoint
+  , insertBetween, pprCmmGraphLikeCmm

   )
 where
 
   )
 where
 

-#include "HsVersions.h"
-
+import BlockId

 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo

-           , CmmCallTarget(..), CmmActuals, CmmFormalsWithoutKinds, CmmFormals
-           , CmmStmt(CmmJump, CmmSwitch) -- imported in order to call ppr
+           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)
+           , CmmStmt(..) -- imported in order to call ppr on Switch and to
+                         -- implement pprCmmGraphLikeCmm
+           , CmmSafety(CmmSafe) -- for pprCmmGraphLikeCmm
+           , CmmReturnInfo(CmmMayReturn) -- for pprCmmGraphLikeCmm

            )
 import PprCmm()
 
 import CLabel
            )
 import PprCmm()
 
 import CLabel

+import CmmZipUtil

 import ClosureInfo
 import FastString
 import ForeignCall
 import MachOp
 import ClosureInfo
 import FastString
 import ForeignCall
 import MachOp

+import qualified ZipCfg as Z

 import qualified ZipDataflow as DF
 import ZipCfg 
 import MkZipCfg
 import qualified ZipDataflow as DF
 import ZipCfg 
 import MkZipCfg

+import Util

 
 import Maybes
 
 import Maybes

-import Outputable hiding (empty)
-import qualified Outputable as PP
+import Monad
+import Outputable

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

+import UniqSet
+import UniqSupply

 
 

-type CmmGraph  = LGraph Middle Last
-type CmmAGraph = AGraph Middle Last
-type CmmBlock  = Block  Middle Last
-type CmmZ      = GenCmm    CmmStatic CmmInfo CmmGraph
-type CmmTopZ   = GenCmmTop CmmStatic CmmInfo CmmGraph
+----------------------------------------------------------------------
+----- Type synonyms and definitions
+
+type CmmGraph                = LGraph Middle Last
+type CmmAGraph               = AGraph Middle Last
+type CmmBlock                = Block  Middle Last
+type CmmZ                    = GenCmm    CmmStatic CmmInfo CmmGraph
+type CmmTopZ                 = GenCmmTop CmmStatic CmmInfo CmmGraph
+type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
+type CmmForwardFixedPoint  a = DF.ForwardFixedPoint  Middle Last a ()

 
 data Middle
 
 data Middle

-  = MidNop
-  | MidComment FastString
+  = MidComment FastString

 
   | MidAssign CmmReg CmmExpr     -- Assign to register
 
 
   | MidAssign CmmReg CmmExpr     -- Assign to register
 

-  | MidStore CmmExpr CmmExpr     -- Assign to memory location.  Size is
+  | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is

                                  -- given by cmmExprRep of the rhs.
 
   | MidUnsafeCall                -- An "unsafe" foreign call;
                                  -- given by cmmExprRep of the rhs.
 
   | MidUnsafeCall                -- An "unsafe" foreign call;

-     CmmCallTarget               -- just a fat machine instructoin
-     CmmFormals              -- zero or more results
+     CmmCallTarget               -- just a fat machine instruction
+     CmmFormals                  -- zero or more results

      CmmActuals                  -- zero or more arguments
 
      CmmActuals                  -- zero or more arguments
 

-  | CopyIn    -- Move parameters or results from conventional locations to registers
-              -- Note [CopyIn invariant]
+  | MidAddToContext              -- push a frame on the stack;
+                                 -- I will return to this frame
+     CmmExpr                     -- The frame's return address; it must be
+                                 -- preceded by an info table that describes the
+                                 -- live variables.
+     [CmmExpr]                   -- The frame's live variables, to go on the 
+                                 -- stack with the first one at the young end
+
+  | CopyIn    -- Move incoming parameters or results from conventional
+              -- locations to registers.  Note [CopyIn invariant]

         Convention 
         Convention 

-        CmmFormals      
+        CmmFormals      -- eventually [CmmKind] will be used only for foreign
+                        -- calls and will migrate into 'Convention' (helping to
+                        -- drain "the swamp"), leaving this as [LocalReg]

         C_SRT           -- Static things kept alive by this block
         C_SRT           -- Static things kept alive by this block

-  | CopyOut Convention CmmFormals 

 
 

-data Last
-  = LastReturn CmmActuals          -- Return from a function,
-                                  -- with these return values.
-
-  | LastJump   CmmExpr CmmActuals
-        -- Tail call to another procedure
-
-  | LastBranch BlockId CmmFormalsWithoutKinds
-        -- To another block in the same procedure
-        -- The parameters are unused at present.
+  | CopyOut Convention CmmActuals
+              -- Move outgoing parameters or results from registers to
+              -- conventional locations.  Every 'LastReturn',
+              -- 'LastJump', or 'LastCall' must be dominated by a
+              -- matching 'CopyOut' in the same basic block.
+              -- As above, '[CmmKind]' will migrate into the foreign calling
+              -- convention, leaving the actuals as '[CmmExpr]'.
+  deriving Eq

 
 

-  | LastCall {                   -- A call (native or safe foreign)
-        cml_target :: CmmCallTarget,
-        cml_actual :: CmmActuals,        -- Zero or more arguments
-        cml_next   :: Maybe BlockId }  -- BlockId of continuation, if call returns
+data Last
+  = LastBranch BlockId  -- Goto another block in the same procedure

 
   | LastCondBranch {            -- conditional branch
         cml_pred :: CmmExpr,
         cml_true, cml_false :: BlockId
     }
 
 
   | LastCondBranch {            -- conditional branch
         cml_pred :: CmmExpr,
         cml_true, cml_false :: BlockId
     }
 

+  | LastReturn          -- Return from a function; values in a previous CopyOut node
+
+  | LastJump CmmExpr    -- Tail call to another procedure; args in a CopyOut node
+
+  | LastCall {                   -- A call (native or safe foreign); args in CopyOut node
+        cml_target :: CmmExpr,   -- never a CmmPrim to a CallishMachOp!
+        cml_cont   :: Maybe BlockId }  -- BlockId of continuation, if call returns
+

   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
         -- The scrutinee is zero-based; 
         --      zero -> first block
   | LastSwitch CmmExpr [Maybe BlockId]   -- Table branch
         -- The scrutinee is zero-based; 
         --      zero -> first block

@@ -88,62 +114,155 @@ data Last
         -- Undefined outside range, and when there's a Nothing
 
 data Convention
         -- Undefined outside range, and when there's a Nothing
 
 data Convention

-  = Argument CCallConv  -- Used for function formal params
-  | Result CCallConv    -- Used for function results
-
-  | Local       -- Used for control transfers within a (pre-CPS) procedure
-                -- All jump sites known, never pushed on the stack (hence no SRT)
-                -- You can choose whatever calling convention
-                -- you please (provided you make sure
-                -- all the call sites agree)!
+  = ConventionStandard CCallConv ValueDirection
+  | ConventionPrivate
+                -- Used for control transfers within a (pre-CPS) procedure All
+                -- jump sites known, never pushed on the stack (hence no SRT)
+                -- You can choose whatever calling convention you please
+                -- (provided you make sure all the call sites agree)!
+                -- This data type eventually to be extended to record the convention. 
+

   deriving Eq
 
   deriving Eq
 

--- ^ In a complete LGraph for a procedure, the [[Exit]] node should not
--- appear, but it is useful in a subgraph (e.g., replacement for a node).
+data ValueDirection = Arguments | Results
+  -- Arguments go with procedure definitions, jumps, and arguments to calls
+  -- Results go with returns and with results of calls.
+  deriving Eq

 
 {-
 Note [CopyIn invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~
 
 {-
 Note [CopyIn invariant]
 ~~~~~~~~~~~~~~~~~~~~~~~

-In principle, CopyIn ought to be a First node, but in practice, the
+One might wish for CopyIn to be a First node, but in practice, the

 possibility raises all sorts of hairy issues with graph splicing,
 rewriting, and so on.  In the end, NR finds it better to make the
 possibility raises all sorts of hairy issues with graph splicing,
 rewriting, and so on.  In the end, NR finds it better to make the

-placement of CopyIn a dynamic invariant.  This change will complicate
-the dataflow fact for the proc-point calculation, but it should make
-things easier in many other respects.  
+placement of CopyIn a dynamic invariant; it should normally be the first
+Middle node in the basic block in which it occurs.

 -}
 
 -}
 

+----------------------------------------------------------------------
+----- Splicing between blocks
+-- Given a middle node, a block, and a successor BlockId,
+-- we can insert the middle node between the block and the successor.
+-- We return the updated block and a list of new blocks that must be added
+-- to the graph.
+-- The semantics is a bit tricky. We consider cases on the last node:
+-- o For a branch, we can just insert before the branch,
+--   but sometimes the optimizer does better if we actually insert
+--   a fresh basic block, enabling some common blockification.
+-- o For a conditional branch, switch statement, or call, we must insert
+--   a new basic block.
+-- o For a jump, or return, this operation is impossible.
+
+insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
+insertBetween b ms succId = insert $ goto_end $ unzip b
+  where insert (h, LastOther (LastBranch bid)) =
+          if bid == succId then
+            do (bid', bs) <- newBlocks
+               return (zipht h $ ZLast $ LastOther (LastBranch bid'), bs)
+          else panic "tried to insert between non-adjacent blocks"
+        insert (h, LastOther (LastCondBranch c t f)) =
+          do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
+             (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
+             return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
+        insert (h, LastOther (LastCall e (Just k))) =
+          if k == succId then
+            do (id', bs) <- newBlocks
+               return (zipht h $ ZLast $ LastOther (LastCall e (Just id')), bs)
+          else panic "tried to insert between non-adjacent blocks"
+        insert (_, LastOther (LastCall _ Nothing)) =
+          panic "cannot insert after non-returning call"
+        insert (h, LastOther (LastSwitch e ks)) =
+          do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
+             return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
+        insert (_, LastOther LastReturn)   = panic "cannot insert after return"
+        insert (_, LastOther (LastJump _)) = panic "cannot insert after jump"
+        insert (_, LastExit) = panic "cannot insert after exit"
+        newBlocks = do id <- liftM BlockId $ getUniqueM
+                       return $ (id, [Block id $
+                                   foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
+        mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
+                               else return (Just k, [])
+        mbNewBlocks Nothing  = return (Nothing, [])
+        lift (id, bs) = (Just id, bs)
+
+
+----------------------------------------------------------------------
+----- Instance declarations for control flow
+

 instance HavingSuccessors Last where
     succs = cmmSuccs
     fold_succs = fold_cmm_succs
 
 instance LastNode Last where
 instance HavingSuccessors Last where
     succs = cmmSuccs
     fold_succs = fold_cmm_succs
 
 instance LastNode Last where

-    mkBranchNode id = LastBranch id []
-    isBranchNode (LastBranch _ []) = True
+    mkBranchNode id = LastBranch id
+    isBranchNode (LastBranch _) = True

     isBranchNode _ = False
     isBranchNode _ = False

-    branchNodeTarget (LastBranch id []) = id
+    branchNodeTarget (LastBranch id) = id

     branchNodeTarget _ = panic "asked for target of non-branch"
 
 cmmSuccs :: Last -> [BlockId]
     branchNodeTarget _ = panic "asked for target of non-branch"
 
 cmmSuccs :: Last -> [BlockId]

-cmmSuccs (LastReturn {})          = []
-cmmSuccs (LastJump {})            = [] 
-cmmSuccs (LastBranch id _)        = [id]
-cmmSuccs (LastCall _ _ (Just id)) = [id]
-cmmSuccs (LastCall _ _ Nothing)   = []
-cmmSuccs (LastCondBranch _ t f)   = [f, t]  -- meets layout constraint
-cmmSuccs (LastSwitch _ edges)     = catMaybes edges
+cmmSuccs (LastReturn {})        = []
+cmmSuccs (LastJump {})          = [] 
+cmmSuccs (LastBranch id)        = [id]
+cmmSuccs (LastCall _ (Just id)) = [id]
+cmmSuccs (LastCall _ Nothing)   = []
+cmmSuccs (LastCondBranch _ t f) = [f, t]  -- meets layout constraint
+cmmSuccs (LastSwitch _ edges)   = catMaybes edges

 
 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 fold_cmm_succs _f (LastReturn {})          z = z
 fold_cmm_succs _f (LastJump {})            z = z
 
 fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
 fold_cmm_succs _f (LastReturn {})          z = z
 fold_cmm_succs _f (LastJump {})            z = z

-fold_cmm_succs  f (LastBranch id _)        z = f id z
-fold_cmm_succs  f (LastCall _ _ (Just id)) z = f id z
-fold_cmm_succs _f (LastCall _ _ Nothing)   z = z
+fold_cmm_succs  f (LastBranch id)          z = f id z
+fold_cmm_succs  f (LastCall _ (Just id))   z = f id z
+fold_cmm_succs _f (LastCall _ Nothing)     z = z

 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 
 fold_cmm_succs  f (LastCondBranch _ te fe) z = f te (f fe z)
 fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edges
 

-
-----------------------------------------------------------------
--- prettyprinting (avoids recursive imports)
+----------------------------------------------------------------------
+----- Instance declarations for register use
+
+instance UserOfLocalRegs Middle where
+    foldRegsUsed f z m = middle m
+      where middle (MidComment {})                = z
+            middle (MidAssign _lhs expr)          = fold f z expr
+            middle (MidStore addr rval)           = fold f (fold f z addr) rval
+            middle (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args
+            middle (MidAddToContext ra args)      = fold f (fold f z ra) args
+            middle (CopyIn _ _formals _)          = z
+            middle (CopyOut _ actuals)            = fold f z actuals
+            fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
+
+instance UserOfLocalRegs Last where
+    foldRegsUsed f z l = last l
+      where last (LastReturn)           = z
+            last (LastJump e)           = foldRegsUsed f z e
+            last (LastBranch _id)       = z
+            last (LastCall tgt _)       = foldRegsUsed f z tgt
+            last (LastCondBranch e _ _) = foldRegsUsed f z e
+            last (LastSwitch e _tbl)    = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs Middle where
+    foldRegsDefd f z m = middle m
+      where middle (MidComment {})       = z
+            middle (MidAssign _lhs _)    = fold f z _lhs
+            middle (MidStore _ _)        = z
+            middle (MidUnsafeCall _ _ _) = z
+            middle (MidAddToContext _ _) = z
+            middle (CopyIn _ _formals _) = fold f z _formals
+            middle (CopyOut _ _)         = z
+            fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction
+
+instance DefinerOfLocalRegs Last where
+    foldRegsDefd _ z l = last l
+      where last (LastReturn)           = z
+            last (LastJump _)           = z
+            last (LastBranch _)         = z
+            last (LastCall _ _)         = z
+            last (LastCondBranch _ _ _) = z
+            last (LastSwitch _ _)       = z
+
+----------------------------------------------------------------------
+----- Instance declarations for prettyprinting (avoids recursive imports)

 
 instance Outputable Middle where
     ppr s = pprMiddle s
 
 instance Outputable Middle where
     ppr s = pprMiddle s

@@ -156,23 +275,22 @@ instance Outputable Convention where
 
 instance DF.DebugNodes Middle Last
 
 
 instance DF.DebugNodes Middle Last
 

-instance Outputable CmmGraph where
-    ppr = pprLgraph
+debugPpr :: Bool
+debugPpr = debugIsOn

 
 pprMiddle :: Middle -> SDoc    
 
 pprMiddle :: Middle -> SDoc    

-pprMiddle stmt = (case stmt of
-
-    MidNop -> semi
+pprMiddle stmt = pp_stmt <+> pp_debug
+ where
+   pp_stmt = case stmt of

 
     CopyIn conv args _ ->
 
     CopyIn conv args _ ->

-        if null args then ptext SLIT("empty CopyIn")
-        else commafy (map pprHinted args) <+> equals <+>
-             ptext SLIT("foreign") <+> doubleQuotes(ppr conv) <+> ptext SLIT("...")
+        if null args then ptext (sLit "empty CopyIn")
+        else commafy (map pprKinded args) <+> equals <+>
+             ptext (sLit "foreign") <+> doubleQuotes(ppr conv) <+> ptext (sLit "...")

 
     CopyOut conv args ->
 
     CopyOut conv args ->

-        if null args then PP.empty
-        else ptext SLIT("CopyOut") <+> doubleQuotes(ppr conv) <+>
-             parens (commafy (map pprHinted args))
+        ptext (sLit "PreCopyOut: next, pass") <+> doubleQuotes(ppr conv) <+>
+        parens (commafy (map pprKinded args))

 
     --  // text
     MidComment s -> text "//" <+> ftext s
 
     --  // text
     MidComment s -> text "//" <+> ftext s

@@ -189,94 +307,205 @@ pprMiddle stmt = (case stmt of
     -- ToDo ppr volatile
     MidUnsafeCall (CmmCallee fn cconv) results args ->
         hcat [ if null results
     -- ToDo ppr volatile
     MidUnsafeCall (CmmCallee fn cconv) results args ->
         hcat [ if null results

-                  then PP.empty
+                  then empty

                   else parens (commafy $ map ppr results) <>
                   else parens (commafy $ map ppr results) <>

-                       ptext SLIT(" = "),
-               ptext SLIT("call"), space, 
+                       ptext (sLit " = "),
+               ptext (sLit "call"), space, 

                doubleQuotes(ppr cconv), space,
                doubleQuotes(ppr cconv), space,

-               target fn, parens  ( commafy $ map ppr args ),
+               ppr_target fn, parens  ( commafy $ map ppr args ),

                semi ]
                semi ]

-        where
-            target t@(CmmLit _) = ppr t
-            target fn'          = parens (ppr fn')

 
     MidUnsafeCall (CmmPrim op) results args ->
         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
 
     MidUnsafeCall (CmmPrim op) results args ->
         pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
         where
           lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)

-  ) <+> text "//" <+>
-  case stmt of
-    MidNop {} -> text "MidNop"
-    CopyIn {} -> text "CopyIn"
-    CopyOut {} -> text "CopyOut"
-    MidComment {} -> text "MidComment"
-    MidAssign {} -> text "MidAssign"
-    MidStore {} -> text "MidStore"
-    MidUnsafeCall {} -> text "MidUnsafeCall"
-
-
-pprHinted :: Outputable a => (a, MachHint) -> SDoc
-pprHinted (a, NoHint)     = ppr a
-pprHinted (a, PtrHint)    = doubleQuotes (text "address") <+> ppr a
-pprHinted (a, SignedHint) = doubleQuotes (text "signed")  <+> ppr a
-pprHinted (a, FloatHint)  = doubleQuotes (text "float")   <+> ppr a
+
+    MidAddToContext ra args ->
+        hcat [ ptext (sLit "return via ")
+             , ppr_target ra, parens (commafy $ map ppr args), semi ]
+
+   pp_debug =
+     if not debugPpr then empty
+     else text " //" <+>
+          case stmt of
+            CopyIn {}     -> text "CopyIn"
+            CopyOut {}    -> text "CopyOut"
+            MidComment {} -> text "MidComment"
+            MidAssign {}  -> text "MidAssign"
+            MidStore {}   -> text "MidStore"
+            MidUnsafeCall  {} -> text "MidUnsafeCall"
+            MidAddToContext {} -> text "MidAddToContext"
+
+
+ppr_target :: CmmExpr -> SDoc
+ppr_target t@(CmmLit _) = ppr t
+ppr_target fn'          = parens (ppr fn')
+
+
+pprKinded :: Outputable a => CmmKinded a -> SDoc
+pprKinded (CmmKinded a NoHint)     = ppr a
+pprKinded (CmmKinded a PtrHint)    = doubleQuotes (text "address") <+> ppr a
+pprKinded (CmmKinded a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
+pprKinded (CmmKinded a FloatHint)  = doubleQuotes (text "float")   <+> ppr a

 
 pprLast :: Last -> SDoc    
 pprLast stmt = (case stmt of
 
 pprLast :: Last -> SDoc    
 pprLast stmt = (case stmt of

-    LastBranch ident args     -> genBranchWithArgs ident args
+    LastBranch ident          -> ptext (sLit "goto") <+> ppr ident <> semi

     LastCondBranch expr t f   -> genFullCondBranch expr t f
     LastCondBranch expr t f   -> genFullCondBranch expr t f

-    LastJump expr params      -> ppr $ CmmJump expr params
-    LastReturn results        -> hcat [ ptext SLIT("return"), space
-                                      , parens ( commafy $ map pprHinted results )
-                                      , semi ]
+    LastJump expr             -> hcat [ ptext (sLit "jump"), space, pprFun expr
+                                      , ptext (sLit "(...)"), semi]
+    LastReturn                -> hcat [ ptext (sLit "return"), space 
+                                      , ptext (sLit "(...)"), semi]

     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids
     LastSwitch arg ids        -> ppr $ CmmSwitch arg ids

-    LastCall tgt params k     -> genCall tgt params k
-  ) <+> text "//" <+>
-  case stmt of
-    LastBranch {} -> text "LastBranch"
-    LastCondBranch {} -> text "LastCondBranch"
-    LastJump {} -> text "LastJump"
-    LastReturn {} -> text "LastReturn"
-    LastSwitch {} -> text "LastSwitch"
-    LastCall {} -> text "LastCall"
-
-
-genCall :: CmmCallTarget -> CmmActuals -> Maybe BlockId -> SDoc
-genCall (CmmCallee fn cconv) args k =
-        hcat [ ptext SLIT("foreign"), space
-             , doubleQuotes(ppr cconv), space
-             , target fn, parens  ( commafy $ map pprHinted args ), space
-             , case k of Nothing -> ptext SLIT("never returns")
-                         Just k -> ptext SLIT("returns to") <+> ppr k
+    LastCall tgt k            -> genBareCall tgt k
+  ) <>
+  if debugPpr then empty
+  else text " //" <+>
+       case stmt of
+         LastBranch {} -> text "LastBranch"
+         LastCondBranch {} -> text "LastCondBranch"
+         LastJump {} -> text "LastJump"
+         LastReturn {} -> text "LastReturn"
+         LastSwitch {} -> text "LastSwitch"
+         LastCall {} -> text "LastCall"
+
+genBareCall :: CmmExpr -> Maybe BlockId -> SDoc
+genBareCall fn k =
+        hcat [ ptext (sLit "call"), space
+             , pprFun fn, ptext (sLit "(...)"), space
+             , case k of Nothing -> ptext (sLit "never returns")
+                         Just k -> ptext (sLit "returns to") <+> ppr k

              , semi ]
         where
              , semi ]
         where

-            target t@(CmmLit _) = ppr t
-            target fn'          = parens (ppr fn')
-
-genCall (CmmPrim op) args k =
-    hcat [ text "%", text (show op), parens  ( commafy $ map pprHinted args ),
-           ptext SLIT("returns to"), space, ppr k,
-           semi ]

 
 

-genBranchWithArgs :: (Outputable id, Outputable arg) => id -> [arg] -> SDoc
-genBranchWithArgs ident [] = ptext SLIT("goto") <+> ppr ident <> semi
-genBranchWithArgs ident args = ptext SLIT("goto") <+> ppr ident <+>
-                               parens (commafy (map ppr args)) <> semi
+pprFun :: CmmExpr -> SDoc
+pprFun f@(CmmLit _) = ppr f
+pprFun f = parens (ppr f)

 
 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 genFullCondBranch expr t f =
 
 genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
 genFullCondBranch expr t f =

-    hsep [ ptext SLIT("if")
+    hsep [ ptext (sLit "if")

          , parens(ppr expr)
          , parens(ppr expr)

-         , ptext SLIT("goto")
+         , ptext (sLit "goto")

          , ppr t <> semi
          , ppr t <> semi

-         , ptext SLIT("else goto")
+         , ptext (sLit "else goto")

          , ppr f <> semi
          ]
 
 pprConvention :: Convention -> SDoc
          , ppr f <> semi
          ]
 
 pprConvention :: Convention -> SDoc

-pprConvention (Argument c) = ppr c
-pprConvention (Result c) = ppr c
-pprConvention Local = text "<local>"
+pprConvention (ConventionStandard c _) = ppr c
+pprConvention (ConventionPrivate {}  ) = text "<private-convention>"

 
 commafy :: [SDoc] -> SDoc
 commafy xs = hsep $ punctuate comma xs
 
 commafy :: [SDoc] -> SDoc
 commafy xs = hsep $ punctuate comma xs

+
+
+----------------------------------------------------------------
+-- | The purpose of this function is to print a Cmm zipper graph "as if it were"
+-- a Cmm program.  The objective is dodgy, so it's unsurprising parts of the
+-- code are dodgy as well.
+
+pprCmmGraphLikeCmm :: CmmGraph -> SDoc
+pprCmmGraphLikeCmm g = vcat (swallow blocks)
+    where blocks = Z.postorder_dfs g
+          swallow :: [CmmBlock] -> [SDoc]
+          swallow [] = []
+          swallow (Z.Block id t : rest) = tail id [] Nothing t rest
+          tail id prev' out (Z.ZTail (CopyOut conv args) t) rest =
+              if isJust out then panic "multiple CopyOut nodes in one basic block"
+              else
+                  tail id (prev') (Just (conv, args)) t rest
+          tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
+          tail id prev' out (Z.ZLast Z.LastExit)      rest = exit id prev' out rest
+          tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
+          mid (CopyIn _ [] _) = text "// proc point (no parameters)"
+          mid m@(CopyIn {}) = ppr m <+> text "(proc point)"
+          mid m = ppr m
+          block' id prev'
+              | id == Z.lg_entry g, entry_has_no_pred =
+                            vcat (text "<entry>" : reverse prev')
+              | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
+          last id prev' out l n =
+              let endblock stmt = block' id (stmt : prev') : swallow n in
+              case l of
+                LastBranch tgt ->
+                    case n of
+                      Z.Block id' t : bs
+                          | tgt == id', unique_pred id' 
+                          -> tail id prev' out t bs  -- optimize out redundant labels
+                      _ -> endblock (ppr $ CmmBranch tgt)
+                l@(LastCondBranch expr tid fid) ->
+                  let ft id = text "// fall through to " <> ppr id in
+                  case n of
+                    Z.Block id' t : bs
+                      | id' == fid, isNothing out ->
+                          tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
+                      | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
+                          tail id (ft tid : ppr (CmmCondBranch e'   fid) : prev') Nothing t bs
+                    _ -> endblock $ with_out out l
+                l@(LastJump   {}) -> endblock $ with_out out l
+                l@(LastReturn {}) -> endblock $ with_out out l
+                l@(LastSwitch {}) -> endblock $ with_out out l
+                l@(LastCall _ Nothing) -> endblock $ with_out out l
+                l@(LastCall tgt (Just k))
+                   | Z.Block id' (Z.ZTail (CopyIn _ ress srt) t) : bs <- n,
+                     Just (conv, args) <- out,
+                     id' == k ->
+                         let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
+                             tgt' = CmmCallee tgt (cconv_of_conv conv)
+                             ppcall = ppr call <+> parens (text "ret to" <+> ppr k)
+                         in if unique_pred k then
+                                tail id (ppcall : prev') Nothing t bs
+                            else
+                                endblock (ppcall)
+                   | Z.Block id' t : bs <- n, id' == k, unique_pred k,
+                     Just (conv, args) <- out,
+                     Just (ress, srt) <- findCopyIn t ->
+                         let call = CmmCall tgt' ress args (CmmSafe srt) CmmMayReturn
+                             tgt' = CmmCallee tgt (cconv_of_conv conv)
+                             delayed =
+                                 ptext (sLit "// delayed CopyIn follows previous call")
+                         in  tail id (delayed : ppr call : prev') Nothing t bs
+                   | otherwise -> endblock $ with_out out l
+          findCopyIn (Z.ZTail (CopyIn _ ress srt) _) = Just (ress, srt)
+          findCopyIn (Z.ZTail _ t) = findCopyIn t
+          findCopyIn (Z.ZLast _) = Nothing
+          exit id prev' out n = -- highly irregular (assertion violation?)
+              let endblock stmt = block' id (stmt : prev') : swallow n in
+              case out of Nothing -> endblock (text "// <exit>")
+                          Just (conv, args) -> endblock (ppr (CopyOut conv args) $$
+                                                         text "// <exit>")
+          preds = zipPreds g
+          entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
+                                Nothing -> True
+                                Just s -> isEmptyUniqSet s
+          single_preds =
+              let add b single =
+                    let id = Z.blockId b
+                    in  case lookupBlockEnv preds id of
+                          Nothing -> single
+                          Just s -> if sizeUniqSet s == 1 then
+                                        extendBlockSet single id
+                                    else single
+              in  Z.fold_blocks add emptyBlockSet g
+          unique_pred id = elemBlockSet id single_preds
+          cconv_of_conv (ConventionStandard conv _) = conv
+          cconv_of_conv (ConventionPrivate {}) = CmmCallConv -- XXX totally bogus
+
+with_out :: Maybe (Convention, CmmActuals) -> Last -> SDoc
+with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
+with_out (Just (conv, args)) l = last l
+    where last (LastCall e k) =
+              hcat [ptext (sLit "... = foreign "),
+                    doubleQuotes(ppr conv), space,
+                    ppr_target e, parens ( commafy $ map ppr args ),
+                    ptext (sLit " \"safe\""),
+                    case k of Nothing -> ptext (sLit " never returns")
+                              Just _ -> empty,
+                    semi ]
+          last (LastReturn) = ppr (CmmReturn args)
+          last (LastJump e) = ppr (CmmJump e args)
+          last l = ppr (CopyOut conv args) $$ ppr l
+          ppr_target (CmmLit lit) = ppr lit
+          ppr_target fn'          = parens (ppr fn')
+          commafy xs = hsep $ punctuate comma xs