Merging in the new codegen branch

This merge does not turn on the new codegen (which only compiles
a select few programs at this point),
but it does introduce some changes to the old code generator.

The high bits:
1. The Rep Swamp patch is finally here.
   The highlight is that the representation of types at the
   machine level has changed.
   Consequently, this patch contains updates across several back ends.
2. The new Stg -> Cmm path is here, although it appears to have a
   fair number of bugs lurking.
3. Many improvements along the CmmCPSZ path, including:
   o stack layout
   o some code for infotables, half of which is right and half wrong
   o proc-point splitting

1 files changed, 292 insertions, 299 deletions

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index af6216835c..e030f4bc58 100644
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -1,4 +1,4 @@
-
+ 
 
 -- This module is pure representation and should be imported only by
 -- clients that need to manipulate representation and know what
@@ -6,29 +6,32 @@
 -- instead import MkZipCfgCmm.
 
 module ZipCfgCmmRep
-  ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, Middle(..), Last(..), Convention(..)
-  , ValueDirection(..), CmmBackwardFixedPoint, CmmForwardFixedPoint
-  , insertBetween, pprCmmGraphLikeCmm
+  ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
+  , Middle(..), Last(..), MidCallTarget(..)
+  , Convention(..), ForeignConvention(..)
+  , ValueDirection(..), ForeignHint(..)
+  , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
+  , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
+  , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast
+  , joinOuts
   )
 where
 
 import BlockId
 import CmmExpr
 import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
-           , CmmCallTarget(..), CmmActuals, CmmFormals, CmmKinded(..)
+           , CallishMachOp(..), ForeignHint(..)
+           , CmmActuals, CmmFormals, CmmHinted(..)
            , CmmStmt(..) -- imported in order to call ppr on Switch and to
                          -- implement pprCmmGraphLikeCmm
-           , CmmSafety(CmmSafe) -- for pprCmmGraphLikeCmm
-           , CmmReturnInfo(CmmMayReturn) -- for pprCmmGraphLikeCmm
            )
+import DFMonad
 import PprCmm()
+import CmmTx
 
 import CLabel
-import CmmZipUtil
-import ClosureInfo
 import FastString
 import ForeignCall
-import MachOp
 import qualified ZipCfg as Z
 import qualified ZipDataflow as DF
 import ZipCfg 
@@ -39,7 +42,7 @@ import Maybes
 import Monad
 import Outputable
 import Prelude hiding (zip, unzip, last)
-import UniqSet
+import qualified Data.List as L
 import UniqSupply
 
 ----------------------------------------------------------------------
@@ -59,36 +62,20 @@ data Middle
   | MidAssign CmmReg CmmExpr     -- Assign to register
 
   | MidStore  CmmExpr CmmExpr    -- Assign to memory location.  Size is
-                                 -- given by cmmExprRep of the rhs.
+                                 -- given by cmmExprType of the rhs.
 
   | MidUnsafeCall                -- An "unsafe" foreign call;
-     CmmCallTarget               -- just a fat machine instruction
+     MidCallTarget               -- just a fat machine instructoin
      CmmFormals                  -- zero or more results
      CmmActuals                  -- zero or more arguments
 
-  | MidAddToContext              -- push a frame on the stack;
-                                 -- I will return to this frame
+  | 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 
-        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
-
-  | 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
 
 data Last
@@ -98,47 +85,54 @@ data Last
         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
         --      one  -> second block etc
         -- Undefined outside range, and when there's a Nothing
+  | LastReturn Int       -- Return from a function; values in previous copy middles
+  | LastJump CmmExpr Int -- Tail call to another procedure; args in a copy middles
+  | LastCall {                      -- A call (native or safe foreign); args in copy middles
+        cml_target :: CmmExpr,      -- never a CmmPrim to a CallishMachOp!
+        cml_cont   :: Maybe BlockId,-- BlockId of continuation, if call returns
+        cml_args   :: Int }     -- liveness info for outgoing args
+  -- All the last nodes that pass arguments carry the size of the outgoing CallArea
+
+data MidCallTarget	-- The target of a MidUnsafeCall
+  = ForeignTarget 	-- A foreign procedure
+	CmmExpr			-- Its address
+	ForeignConvention	-- Its calling convention
+
+  | PrimTarget		-- A possibly-side-effecting machine operation
+	CallishMachOp		-- Which one
+  deriving Eq
 
 data Convention
-  = 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
+  = Native 		-- Native C-- call/return
+
+  | Foreign		-- Foreign call/return
+	ForeignConvention
+
+  | Private
+        -- 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 )
+
+data ForeignConvention
+  = ForeignConvention
+	CCallConv 		-- Which foreign-call convention
+	[ForeignHint]		-- Extra info about the args
+	[ForeignHint]		-- Extra info about the result
+  deriving Eq 
 
 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]
-~~~~~~~~~~~~~~~~~~~~~~~
-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
-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,
@@ -151,41 +145,35 @@ Middle node in the basic block in which it occurs.
 --   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.
+-- 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"
+               return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
+          else panic "tried invalid block insertBetween"
         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 (_, LastOther (LastCall _ _ _)) =
+          panic "unimp: insertBetween after a call -- probably not a good idea"
+        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 $
+                       return $ (id, [Block id Nothing $
                                    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
 
@@ -201,20 +189,20 @@ instance LastNode Last where
     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 (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 (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
 
@@ -223,43 +211,164 @@ fold_cmm_succs  f (LastSwitch _ edges)     z = foldl (flip f) z $ catMaybes edge
 
 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
+      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 _ args) = fold f (fold f z tgt) args
+            middle (MidAddToContext ra args)  = fold f (fold f z ra) args
             fold f z m = foldRegsUsed f z m  -- avoid monomorphism restriction
 
+instance UserOfLocalRegs MidCallTarget where
+  foldRegsUsed _f z (PrimTarget _)      = z
+  foldRegsUsed f  z (ForeignTarget e _) = foldRegsUsed f z e
+
+instance UserOfSlots MidCallTarget where
+  foldSlotsUsed _f z (PrimTarget _)      = z
+  foldSlotsUsed f  z (ForeignTarget e _) = foldSlotsUsed f z e
+
 instance UserOfLocalRegs Last where
     foldRegsUsed f z l = last l
-      where last (LastReturn)           = z
-            last (LastJump e)           = foldRegsUsed f z e
+      where last (LastReturn _)         = z
+            last (LastJump e _)         = foldRegsUsed f z e
             last (LastBranch _id)       = z
-            last (LastCall tgt _)       = foldRegsUsed f z tgt
+            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
+            fold f z m = foldRegsDefd f z m  -- avoid monomorphism restriction
+
+instance DefinerOfLocalRegs Last where
+    foldRegsDefd _ z _ = z
+
+
+----------------------------------------------------------------------
+----- Instance declarations for stack slot use
+
+instance UserOfSlots Middle where
+    foldSlotsUsed 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
+            fold f z e = foldSlotsUsed f z e  -- avoid monomorphism restriction
+
+instance UserOfSlots Last where
+    foldSlotsUsed f z l = last l
+      where last (LastReturn _)         = z
+            last (LastJump e _)         = foldSlotsUsed f z e
+            last (LastBranch _id)       = z
+            last (LastCall tgt _ _)     = foldSlotsUsed f z tgt
+            last (LastCondBranch e _ _) = foldSlotsUsed f z e
+            last (LastSwitch e _tbl)    = foldSlotsUsed f z e
+
+instance UserOfSlots l => UserOfSlots (ZLast l) where
+    foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
+    foldSlotsUsed _ z LastExit      = z
+
+instance DefinerOfSlots Middle where
+    foldSlotsDefd f z m = middle m
       where middle (MidComment {})       = z
-            middle (MidAssign _lhs _)    = fold f z _lhs
+            middle (MidAssign _ _)       = z
+            middle (MidStore (CmmStackSlot a i) e) =
+              f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
             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 DefinerOfSlots Last where
+    foldSlotsDefd _ z _ = z
+
+instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
+    foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
+    foldSlotsDefd _ z LastExit      = z
+
+----------------------------------------------------------------------
+----- Code for manipulating Middle and Last nodes
+
+mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
+mapExpMiddle _   m@(MidComment _)            = m
+mapExpMiddle exp   (MidAssign r e)           = MidAssign r (exp e)
+mapExpMiddle exp   (MidStore addr e)         = MidStore (exp addr) (exp e)
+mapExpMiddle exp   (MidUnsafeCall tgt fs as) =
+  MidUnsafeCall (mapExpMidcall exp tgt) fs (map exp as)
+mapExpMiddle exp   (MidAddToContext e es)    = MidAddToContext (exp e) (map exp es)
+
+foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
+foldExpMiddle _   (MidComment _)           z = z
+foldExpMiddle exp (MidAssign _ e)          z = exp e z
+foldExpMiddle exp (MidStore addr e)        z = exp addr $ exp e z
+foldExpMiddle exp (MidUnsafeCall tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
+foldExpMiddle exp (MidAddToContext e es)   z = exp e $ foldr exp z es
+
+mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
+mapExpLast _   l@(LastBranch _)         = l
+mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
+mapExpLast exp (LastSwitch e tbl)       = LastSwitch (exp e) tbl
+mapExpLast exp (LastCall tgt mb_id s)   = LastCall (exp tgt) mb_id s
+mapExpLast exp (LastJump e s)           = LastJump (exp e) s
+mapExpLast _   (LastReturn s)           = LastReturn s
+
+foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
+foldExpLast _   (LastBranch _)         z = z
+foldExpLast exp (LastCondBranch e _ _) z = exp e z
+foldExpLast exp (LastSwitch e _)       z = exp e z
+foldExpLast exp (LastCall tgt _ _)     z = exp tgt z
+foldExpLast exp (LastJump e _)         z = exp e z
+foldExpLast _   (LastReturn _)         z = z
+
+mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget 
+mapExpMidcall exp   (ForeignTarget e c) = ForeignTarget (exp e) c
+mapExpMidcall _   m@(PrimTarget _)      = m
+
+foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z 
+foldExpMidcall exp (ForeignTarget e _) z = exp e z
+foldExpMidcall _   (PrimTarget _)      z = z
+
+-- Take a transformer on expressions and apply it recursively.
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+wrapRecExp f (CmmMachOp op es)    = f (CmmMachOp op $ map f es)
+wrapRecExp f (CmmLoad addr ty)    = f (CmmLoad (f addr) ty)
+wrapRecExp f e                    = f e
+
+mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
+mapExpDeepLast   :: (CmmExpr -> CmmExpr) -> Last   -> Last
+mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
+mapExpDeepLast   f = mapExpLast   $ wrapRecExp f
+
+-- Take a folder on expressions and apply it recursively.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr f (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = f addr  (f e z)
+wrapRecExpf f e                  z = f e z
+
+foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
+foldExpDeepLast   :: (CmmExpr -> z -> z) -> Last   -> z -> z
+foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
+foldExpDeepLast   f = foldExpLast   $ wrapRecExpf f
+
+----------------------------------------------------------------------
+-- Compute the join of facts live out of a Last node. Useful for most backward
+-- analyses.
+joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
+joinOuts lattice env l =
+  let bot  = fact_bot lattice
+      join x y = txVal $ fact_add_to lattice x y
+  in case l of
+       (LastReturn _)          -> bot
+       (LastJump _ _)          -> bot
+       (LastBranch id)         -> env id
+       (LastCall _ Nothing _)  -> bot
+       (LastCall _ (Just k) _) -> env k
+       (LastCondBranch _ t f)  -> join (env t) (env f)
+       (LastSwitch _ tbl)      -> foldr join bot (map env $ catMaybes tbl)
 
 ----------------------------------------------------------------------
 ----- Instance declarations for prettyprinting (avoids recursive imports)
@@ -273,6 +382,13 @@ instance Outputable Last where
 instance Outputable Convention where
     ppr = pprConvention
 
+instance Outputable ForeignConvention where
+    ppr = pprForeignConvention
+
+instance Outputable ValueDirection where
+    ppr Arguments = ptext $ sLit "args"
+    ppr Results   = ptext $ sLit "results"
+
 instance DF.DebugNodes Middle Last
 
 debugPpr :: Bool
@@ -280,94 +396,78 @@ debugPpr = debugIsOn
 
 pprMiddle :: Middle -> SDoc    
 pprMiddle stmt = pp_stmt <+> pp_debug
- where
-   pp_stmt = case stmt of
-
-    CopyIn conv args _ ->
-        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 ->
-        ptext (sLit "PreCopyOut: next, pass") <+> doubleQuotes(ppr conv) <+>
-        parens (commafy (map pprKinded args))
-
-    --  // text
-    MidComment s -> text "//" <+> ftext s
-
-    -- reg = expr;
-    MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-
-    -- rep[lv] = expr;
-    MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
-        where
-          rep = ppr ( cmmExprRep expr )
-
-    -- call "ccall" foo(x, y)[r1, r2];
-    -- ToDo ppr volatile
-    MidUnsafeCall (CmmCallee fn cconv) results args ->
-        hcat [ if null results
-                  then empty
-                  else parens (commafy $ map ppr results) <>
-                       ptext (sLit " = "),
-               ptext (sLit "call"), space, 
-               doubleQuotes(ppr cconv), space,
-               ppr_target fn, parens  ( commafy $ map ppr args ),
-               semi ]
-
-    MidUnsafeCall (CmmPrim op) results args ->
-        pprMiddle (MidUnsafeCall (CmmCallee (CmmLit lbl) CCallConv) results args)
-        where
-          lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
-
-    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"
-
+  where
+    pp_stmt = case stmt of
+    	--  // text
+    	MidComment s -> text "//" <+> ftext s
+
+    	-- reg = expr;
+    	MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+    	-- rep[lv] = expr;
+    	MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+    	    where
+    	      rep = ppr ( cmmExprType expr )
+
+    	-- call "ccall" foo(x, y)[r1, r2];
+    	-- ToDo ppr volatile
+    	MidUnsafeCall target results args ->
+    	    hsep [ if null results
+    	              then empty
+    	              else parens (commafy $ map ppr results) <+> equals,
+    	           ptext $ sLit "call", 
+    	           ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
+
+    	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
+             MidComment {} -> text "MidComment"
+             MidAssign {}  -> text "MidAssign"
+             MidStore {}   -> text "MidStore"
+             MidUnsafeCall  {} -> text "MidUnsafeCall"
+             MidAddToContext {} -> text "MidAddToContext"
+
+ppr_fc :: ForeignConvention -> SDoc
+ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c)
+
+ppr_call_target :: MidCallTarget -> SDoc
+ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
+ppr_call_target (PrimTarget op)      = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False))
 
 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
+pprHinted :: Outputable a => CmmHinted a -> SDoc
+pprHinted (CmmHinted a NoHint)     = ppr a
+pprHinted (CmmHinted a AddrHint)   = doubleQuotes (text "address") <+> ppr a
+pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed")  <+> ppr a
 
 pprLast :: Last -> SDoc    
-pprLast stmt = (case stmt of
-    LastBranch ident          -> ptext (sLit "goto") <+> ppr ident <> semi
-    LastCondBranch expr t f   -> genFullCondBranch expr t f
-    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
-    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"
+pprLast stmt = pp_stmt <+> pp_debug
+  where
+    pp_stmt = case stmt of
+       LastBranch ident          -> ptext (sLit "goto") <+> ppr ident <> semi
+       LastCondBranch expr t f   -> genFullCondBranch expr t f
+       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
+       LastCall tgt k _          -> genBareCall tgt k
+
+    pp_debug = 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 =
@@ -393,119 +493,12 @@ genFullCondBranch expr t f =
          ]
 
 pprConvention :: Convention -> SDoc
-pprConvention (ConventionStandard c _) = ppr c
-pprConvention (ConventionPrivate {}  ) = text "<private-convention>"
+pprConvention (Native {})  = empty
+pprConvention (Foreign c)  = ppr c
+pprConvention (Private {}) = text "<private-convention>"
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
 
 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