Remove OldCmm, convert backends to consume new Cmm

This removes the OldCmm data type and the CmmCvt pass that converts
new Cmm to OldCmm.  The backends (NCGs, LLVM and C) have all been
converted to consume new Cmm.

The main difference between the two data types is that conditional
branches in new Cmm have both true/false successors, whereas in OldCmm
the false case was a fallthrough.  To generate slightly better code we
occasionally need to invert a conditional to ensure that the
branch-not-taken becomes a fallthrough; this was previously done in
CmmCvt, and it is now done in CmmContFlowOpt.

We could go further and use the Hoopl Block representation for native
code, which would mean that we could use Hoopl's postorderDfs and
analyses for native code, but for now I've left it as is, using the
old ListGraph representation for native code.

14 files changed, 196 insertions, 1031 deletions

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index e1701bd4c5..0b3040d597 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -8,8 +8,13 @@ module Cmm (
      CmmDecl, GenCmmDecl(..),
      CmmGraph, GenCmmGraph(..),
      CmmBlock,
+     RawCmmDecl, RawCmmGroup,
      Section(..), CmmStatics(..), CmmStatic(..),
 
+     -- ** Blocks containing lists
+     GenBasicBlock(..), blockId,
+     ListGraph(..), pprBBlock,
+
      -- * Cmm graphs
      CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite,
    
@@ -31,6 +36,7 @@ import SMRep
 import CmmExpr
 import UniqSupply
 import Compiler.Hoopl
+import Outputable
 
 import Data.Word        ( Word8 )
 
@@ -50,6 +56,7 @@ type CmmProgram = [CmmGroup]
 
 type GenCmmGroup d h g = [GenCmmDecl d h g]
 type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
+type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) CmmGraph
 
 -----------------------------------------------------------------------------
 --  CmmDecl, GenCmmDecl
@@ -62,7 +69,6 @@ type CmmGroup = GenCmmGroup CmmStatics CmmTopInfo CmmGraph
 --
 -- We expect there to be two main instances of this type:
 --   (a) C--, i.e. populated with various C-- constructs
---       (Cmm and RawCmm in OldCmm.hs)
 --   (b) Native code, populated with data/instructions
 
 -- | A top-level chunk, abstracted over the type of the contents of
@@ -87,6 +93,12 @@ data GenCmmDecl d h g
 
 type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
 
+type RawCmmDecl
+   = GenCmmDecl
+        CmmStatics
+        (BlockEnv CmmStatics)
+        CmmGraph
+
 -----------------------------------------------------------------------------
 --     Graphs
 -----------------------------------------------------------------------------
@@ -177,3 +189,28 @@ data CmmStatics
        CLabel      -- Label of statics
        [CmmStatic] -- The static data itself
 
+-- -----------------------------------------------------------------------------
+-- Basic blocks consisting of lists
+
+-- These are used by the LLVM and NCG backends, when populating Cmm
+-- with lists of instructions.
+
+data GenBasicBlock i = BasicBlock BlockId [i]
+
+-- | The branch block id is that of the first block in
+-- the branch, which is that branch's entry point
+blockId :: GenBasicBlock i -> BlockId
+blockId (BasicBlock blk_id _ ) = blk_id
+
+newtype ListGraph i = ListGraph [GenBasicBlock i]
+
+instance Outputable instr => Outputable (ListGraph instr) where
+    ppr (ListGraph blocks) = vcat (map ppr blocks)
+
+instance Outputable instr => Outputable (GenBasicBlock instr) where
+    ppr = pprBBlock
+
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs
index 82f7243e73..c59a4342b4 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/cmm/CmmContFlowOpt.hs
@@ -4,17 +4,18 @@
 module CmmContFlowOpt
     ( cmmCfgOpts
     , cmmCfgOptsProc
+    , removeUnreachableBlocksProc
     , removeUnreachableBlocks
     , replaceLabels
     )
 where
 
+import Hoopl
 import BlockId
 import Cmm
 import CmmUtils
 import Maybes
 
-import Hoopl
 import Control.Monad
 import Prelude hiding (succ, unzip, zip)
 
@@ -136,9 +137,10 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
         = (blocks, mapInsert b' dest shortcut_map)
            -- replaceLabels will substitute dest for b' everywhere, later
 
-        -- non-calls: see if we can shortcut any of the successors.
+        -- non-calls: see if we can shortcut any of the successors,
+        -- and check whether we should invert the conditional
         | Nothing <- callContinuation_maybe last
-        = ( mapInsert bid (blockJoinTail head shortcut_last) blocks
+        = ( mapInsert bid (blockJoinTail head swapcond_last) blocks
           , shortcut_map )
 
         | otherwise
@@ -146,17 +148,38 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
         where
           (head, last) = blockSplitTail block
           bid = entryLabel block
+
           shortcut_last = mapSuccessors shortcut last
-          shortcut l =
-             case mapLookup l blocks of
-               Just b | Just dest <- canShortcut b  -> dest
-               _otherwise -> l
+            where
+              shortcut l =
+                 case mapLookup l blocks of
+                   Just b | Just dest <- canShortcut b  -> dest
+                   _otherwise -> l
+
+          -- for a conditional, we invert the conditional if that
+          -- would make it more likely that the branch-not-taken case
+          -- becomes a fallthrough.  This helps the native codegen a
+          -- little bit, and probably has no effect on LLVM.  It's
+          -- convenient to do it here, where we have the information
+          -- about predecessors.
+          --
+          swapcond_last
+            | CmmCondBranch cond t f <- shortcut_last
+            , numPreds f > 1
+            , numPreds t == 1
+            , Just cond' <- maybeInvertCmmExpr cond
+            = CmmCondBranch cond' f t
+
+            | otherwise
+            = shortcut_last
+
 
      shouldConcatWith b block
        | okToDuplicate block = True  -- short enough to duplicate
-       | num_preds b == 1    = True  -- only one predecessor: go for it
+       | numPreds b == 1     = True  -- only one predecessor: go for it
        | otherwise           = False
-       where num_preds bid = mapLookup bid backEdges `orElse` 0
+
+     numPreds bid = mapLookup bid backEdges `orElse` 0
 
      canShortcut :: CmmBlock -> Maybe BlockId
      canShortcut block
@@ -265,6 +288,10 @@ predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
 --
 -- Removing unreachable blocks
 
+removeUnreachableBlocksProc :: CmmDecl -> CmmDecl
+removeUnreachableBlocksProc (CmmProc info lbl live g)
+   = CmmProc info lbl live (removeUnreachableBlocks g)
+
 removeUnreachableBlocks :: CmmGraph -> CmmGraph
 removeUnreachableBlocks g
   | length blocks < mapSize (toBlockMap g) = ofBlockList (g_entry g) blocks
diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs
deleted file mode 100644
index 39f0b86ec8..0000000000
--- a/compiler/cmm/CmmCvt.hs
+++ /dev/null
@@ -1,117 +0,0 @@
-{-# LANGUAGE GADTs #-}
--- ToDo: remove -fno-warn-incomplete-patterns
-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-
-module CmmCvt
-  ( cmmOfZgraph )
-where
-
-import BlockId
-import Cmm
-import CmmUtils
-import qualified OldCmm as Old
-import OldPprCmm ()
-
-import Hoopl
-import Data.Maybe
-import Maybes
-import Outputable
-
-cmmOfZgraph :: CmmGroup -> Old.CmmGroup
-cmmOfZgraph tops = map mapTop tops
-  where mapTop (CmmProc h l v g) = CmmProc (info_tbls h) l v (ofZgraph g)
-        mapTop (CmmData s ds) = CmmData s ds
-
-add_hints :: [a] -> [ForeignHint] -> [Old.CmmHinted a]
-add_hints args hints = zipWith Old.CmmHinted args hints
-
-get_hints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
-get_hints (PrimTarget op) = (res_hints ++ repeat NoHint,
-                             arg_hints ++ repeat NoHint)
-  where (res_hints, arg_hints) = callishMachOpHints op
-get_hints (ForeignTarget _ (ForeignConvention _ arg_hints res_hints _))
-  = (res_hints, arg_hints)
-
-cmm_target :: ForeignTarget -> Old.CmmCallTarget
-cmm_target (PrimTarget op) = Old.CmmPrim op Nothing
-cmm_target (ForeignTarget e (ForeignConvention cc _ _ _)) = Old.CmmCallee e cc
-
-get_ret :: ForeignTarget -> CmmReturnInfo
-get_ret (PrimTarget _) = CmmMayReturn
-get_ret (ForeignTarget _ (ForeignConvention _ _ _ ret)) = ret
-
-ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
-ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
-  -- We catenated some blocks in the conversion process,
-  -- because of the CmmCondBranch -- the machine code does not have
-  -- 'jump here or there' instruction, but has 'jump if true' instruction.
-  -- As OldCmm has the same instruction, so we use it.
-  -- When we are doing this, we also catenate normal goto-s (it is for free).
-
-  -- Exactly, we catenate blocks with nonentry labes, that are
-  --   a) mentioned exactly once as a successor
-  --   b) any of 1) are a target of a goto
-  --             2) are false branch target of a conditional jump
-  --             3) are true branch target of a conditional jump, and
-  --                  the false branch target is a successor of at least 2 blocks
-  --                  and the condition can be inverted
-  -- The complicated rule 3) is here because we need to assign at most one
-  -- catenable block to a CmmCondBranch.
-    where preds :: BlockEnv [CmmNode O C]
-          preds = mapFold add mapEmpty $ toBlockMap g
-            where add block env = foldr (add' $ lastNode block) env (successors block)
-                  add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
-                  add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
-
-          to_be_catenated :: BlockId -> Bool
-          to_be_catenated id | id == g_entry g = False
-                             | Just [CmmBranch _] <- mapLookup id preds = True
-                             | Just [CmmCondBranch _ _ f] <- mapLookup id preds
-                             , f == id = True
-                             | Just [CmmCondBranch e t f] <- mapLookup id preds
-                             , t == id
-                             , Just (_:_:_) <- mapLookup f preds
-                             , Just _ <- maybeInvertCmmExpr e = True
-          to_be_catenated _ = False
-
-          convert_block block | to_be_catenated (entryLabel block) = Nothing
-          convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
-            where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
-                  first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
-
-                  middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
-                  middle node stmts = stmt : stmts
-                    where stmt :: Old.CmmStmt
-                          stmt = case node of
-                            CmmComment s                                   -> Old.CmmComment s
-                            CmmAssign l r                                  -> Old.CmmAssign l r
-                            CmmStore  l r                                  -> Old.CmmStore  l r
-                            CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
-                            CmmUnsafeForeignCall target ress args          ->
-                              Old.CmmCall (cmm_target target)
-                                          (add_hints ress res_hints)
-                                          (add_hints args arg_hints)
-                                          (get_ret target)
-                                  where
-                                     (res_hints, arg_hints) = get_hints target
-
-
-                  last :: CmmNode O C -> () -> [Old.CmmStmt]
-                  last node _ = stmts
-                    where stmts :: [Old.CmmStmt]
-                          stmts = case node of
-                            CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
-                                          | otherwise -> [Old.CmmBranch tgt]
-                            CmmCondBranch expr tid fid
-                              | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
-                              | to_be_catenated tid
-                              , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
-                              | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
-                            CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
-                            -- ToDo: STG Live
-                            CmmCall e _ r _ _ _ -> [Old.CmmJump e r]
-                            CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
-                          tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
-                                          Old.BasicBlock _ stmts -> stmts
-                            where Just block = mapLookup bid $ toBlockMap g
-
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index 699469c116..b4e2cd66dd 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -14,8 +14,7 @@ module CmmInfo (
 
 #include "HsVersions.h"
 
-import OldCmm as Old
-
+import Cmm
 import CmmUtils
 import CLabel
 import SMRep
@@ -42,8 +41,8 @@ mkEmptyContInfoTable info_lbl
                  , cit_prof = NoProfilingInfo
                  , cit_srt  = NoC_SRT }
 
-cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
-            -> IO (Stream IO Old.RawCmmGroup ())
+cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
+            -> IO (Stream IO RawCmmGroup ())
 cmmToRawCmm dflags cmms
   = do { uniqs <- mkSplitUniqSupply 'i'
        ; let do_one uniqs cmm = do
@@ -108,21 +107,13 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
           rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
           rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
         --
-        case blocks of
-          ListGraph [] ->
-              -- No code; only the info table is significant
-              -- Use a zero place-holder in place of the
-              -- entry-label in the info table
-              return (top_decls ++
-                      [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
-                                                                rel_extra_bits)])
-          _nonempty ->
-             -- Separately emit info table (with the function entry
-             -- point as first entry) and the entry code
-             return (top_decls ++
-                     [CmmProc mapEmpty entry_lbl live blocks,
-                      mkDataLits Data info_lbl
-                         (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
+        -- Separately emit info table (with the function entry
+        -- point as first entry) and the entry code
+        --
+        return (top_decls ++
+                [CmmProc mapEmpty entry_lbl live blocks,
+                 mkDataLits Data info_lbl
+                    (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
 
   --
   -- With tables-next-to-code, we can have many info tables,
@@ -132,7 +123,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
   --
   | otherwise
   = do
-    (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
+    (top_declss, raw_infos) <-
+       unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
     return (concat top_declss ++
             [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
 
diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs
index 6fa3007fbe..d808c7ff0d 100644
--- a/compiler/cmm/CmmNode.hs
+++ b/compiler/cmm/CmmNode.hs
@@ -12,7 +12,8 @@
 
 module CmmNode (
      CmmNode(..), CmmFormal, CmmActual,
-     UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..),
+     UpdFrameOffset, Convention(..),
+     ForeignConvention(..), ForeignTarget(..), foreignTargetHints,
      CmmReturnInfo(..),
      mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf,
      mapExpM, mapExpDeepM, wrapRecExpM, mapSuccessors
@@ -281,6 +282,17 @@ data ForeignTarget        -- The target of a foreign call
         CallishMachOp            -- Which one
   deriving Eq
 
+foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
+foreignTargetHints target
+  = ( res_hints ++ repeat NoHint
+    , arg_hints ++ repeat NoHint )
+  where
+    (res_hints, arg_hints) =
+       case target of
+          PrimTarget op -> callishMachOpHints op
+          ForeignTarget _ (ForeignConvention _ arg_hints res_hints _) ->
+             (res_hints, arg_hints)
+
 --------------------------------------------------
 -- Instances of register and slot users / definers
 
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs
index 0d44f0ffd5..f89c08178e 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/cmm/CmmOpt.hs
@@ -8,14 +8,13 @@
 
 module CmmOpt (
         cmmMachOpFold,
-        cmmMachOpFoldM,
-        cmmLoopifyForC,
+        cmmMachOpFoldM
  ) where
 
 #include "HsVersions.h"
 
 import CmmUtils
-import OldCmm
+import Cmm
 import DynFlags
 import CLabel
 
@@ -416,6 +415,7 @@ exactLog2 x_
   except factorial, but what the hell.
 -}
 
+{-
 cmmLoopifyForC :: DynFlags -> RawCmmDecl -> RawCmmDecl
 -- XXX: revisit if we actually want to do this
 -- cmmLoopifyForC p@(CmmProc Nothing _ _) = p  -- only if there's an info table, ignore case alts
@@ -434,6 +434,7 @@ cmmLoopifyForC dflags (CmmProc infos entry_lbl live
                  | otherwise               = entry_lbl
 
 cmmLoopifyForC _ top = top
+-}
 
 -- -----------------------------------------------------------------------------
 -- Utils
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/cmm/CmmPipeline.hs
index 70ff754166..4e9a90a153 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/cmm/CmmPipeline.hs
@@ -134,6 +134,8 @@ cpsTop hsc_env proc =
                   return $ if optLevel dflags >= 1
                              then map (cmmCfgOptsProc splitting_proc_points) gs
                              else gs
+            gs <- return (map removeUnreachableBlocksProc gs)
+                -- Note [unreachable blocks]
             dumps Opt_D_dump_cmmz_cfg "Post control-flow optimsations" gs
 
             return (cafEnv, gs)
@@ -152,6 +154,8 @@ cpsTop hsc_env proc =
                  return $ if optLevel dflags >= 1
                              then cmmCfgOptsProc splitting_proc_points g
                              else g
+            g <- return (removeUnreachableBlocksProc g)
+                -- Note [unreachable blocks]
             dump' Opt_D_dump_cmmz_cfg "Post control-flow optimsations" g
 
             return (cafEnv, [g])
@@ -212,7 +216,15 @@ _GLOBAL_OFFSET_TABLE_, regardless of which entry point we arrived via.
 
 -}
 
+{- Note [unreachable blocks]
 
+The control-flow optimiser sometimes leaves unreachable blocks behind
+containing junk code.  If these blocks make it into the native code
+generator then they trigger a register allocator panic because they
+refer to undefined LocalRegs, so we must eliminate any unreachable
+blocks before passing the code onwards.
+
+-}
 
 runUniqSM :: UniqSM a -> IO a
 runUniqSM m = do
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs
index d52c6a3a56..c822da9673 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/cmm/CmmUtils.hs
@@ -51,9 +51,8 @@ module CmmUtils(
         -- * Operations that probably don't belong here
         modifyGraph,
 
-        lastNode, replaceLastNode,
         ofBlockMap, toBlockMap, insertBlock,
-        ofBlockList, toBlockList, bodyToBlockList,
+        ofBlockList, toBlockList, bodyToBlockList, toBlockListEntryFirst,
         foldGraphBlocks, mapGraphNodes, postorderDfs, mapGraphNodes1,
 
         analFwd, analBwd, analRewFwd, analRewBwd,
@@ -424,6 +423,17 @@ insertBlock block map =
 toBlockList :: CmmGraph -> [CmmBlock]
 toBlockList g = mapElems $ toBlockMap g
 
+-- | like 'toBlockList', but the entry block always comes first
+toBlockListEntryFirst :: CmmGraph -> [CmmBlock]
+toBlockListEntryFirst g
+  | mapNull m  = []
+  | otherwise  = entry_block : others
+  where
+    m = toBlockMap g
+    entry_id = g_entry g
+    Just entry_block = mapLookup entry_id m
+    others = filter ((/= entry_id) . entryLabel) (mapElems m)
+
 ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
 ofBlockList entry blocks = CmmGraph { g_entry = entry
                                     , g_graph = GMany NothingO body NothingO }
diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs
deleted file mode 100644
index fccdd8137d..0000000000
--- a/compiler/cmm/OldCmm.hs
+++ /dev/null
@@ -1,279 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-
------------------------------------------------------------------------------
---
--- Old-style Cmm data types
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module OldCmm (
-        CmmGroup, GenCmmGroup, RawCmmGroup, CmmDecl, RawCmmDecl,
-        ListGraph(..),
-        CmmInfoTable(..), ClosureTypeInfo(..), topInfoTable,
-        CmmStatic(..), CmmStatics(..), CmmFormal, CmmActual,
-
-        cmmMapGraph, cmmTopMapGraph,
-
-        GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
-
-        CmmStmt(..), New.CmmReturnInfo(..), CmmHinted(..),
-        HintedCmmFormal, HintedCmmActual,
-
-        CmmSafety(..), CmmCallTarget(..),
-        New.GenCmmDecl(..), New.ForeignHint(..),
-
-        module CmmExpr,
-
-        Section(..), ProfilingInfo(..), New.C_SRT(..)
-    ) where
-
-#include "HsVersions.h"
-
-import qualified Cmm as New
-import Cmm ( CmmInfoTable(..), GenCmmGroup, CmmStatics(..), GenCmmDecl(..),
-             CmmFormal, CmmActual, Section(..), CmmStatic(..),
-             ProfilingInfo(..), ClosureTypeInfo(..) )
-
-import BlockId
-import CmmExpr
-import FastString
-import ForeignCall
-
-
--- A [[BlockId]] is a local label.
--- Local labels must be unique within an entire compilation unit, not
--- just a single top-level item, because local labels map one-to-one
--- with assembly-language labels.
-
------------------------------------------------------------------------------
---  Cmm, CmmDecl, CmmBasicBlock
------------------------------------------------------------------------------
-
--- A file is a list of top-level chunks.  These may be arbitrarily
--- re-orderd during code generation.
-
--- | A control-flow graph represented as a list of extended basic blocks.
---
--- Code, may be empty.  The first block is the entry point.  The
--- order is otherwise initially unimportant, but at some point the
--- code gen will fix the order.
---
--- BlockIds must be unique across an entire compilation unit, since
--- they are translated to assembly-language labels, which scope
--- across a whole compilation unit.
-newtype ListGraph i = ListGraph [GenBasicBlock i]
-
-type CmmInfoTables = BlockEnv CmmInfoTable
-
--- | Cmm with the info table as a data type
-type CmmGroup = GenCmmGroup CmmStatics CmmInfoTables (ListGraph CmmStmt)
-type CmmDecl = GenCmmDecl CmmStatics CmmInfoTables (ListGraph CmmStmt)
-
--- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info
--- table label. If we are building without tables-next-to-code there will be no statics
---
--- INVARIANT: if there is an info table, it has at least one CmmStatic
-type RawCmmGroup = GenCmmGroup CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt)
-type RawCmmDecl = GenCmmDecl CmmStatics (BlockEnv CmmStatics) (ListGraph CmmStmt)
-
-
--- A basic block containing a single label, at the beginning.
--- The list of basic blocks in a top-level code block may be re-ordered.
--- Fall-through is not allowed: there must be an explicit jump at the
--- end of each basic block, but the code generator might rearrange basic
--- blocks in order to turn some jumps into fallthroughs.
-
-data GenBasicBlock i = BasicBlock BlockId [i]
-type CmmBasicBlock   = GenBasicBlock CmmStmt
-
-instance UserOfRegs r i => UserOfRegs r (GenBasicBlock i) where
-    foldRegsUsed dflags f set (BasicBlock _ l) = foldRegsUsed dflags f set l
-
--- | The branch block id is that of the first block in
--- the branch, which is that branch's entry point
-blockId :: GenBasicBlock i -> BlockId
-blockId (BasicBlock blk_id _ ) = blk_id
-
-blockStmts :: GenBasicBlock i -> [i]
-blockStmts (BasicBlock _ stmts) = stmts
-
-mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i'
-mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
-
--- | Returns the info table associated with the CmmDecl's entry point,
--- if any.
-topInfoTable :: GenCmmDecl a (BlockEnv i) (ListGraph b) -> Maybe i
-topInfoTable (CmmProc infos _ _ (ListGraph (b:_)))
-  = mapLookup (blockId b) infos
-topInfoTable _
-  = Nothing
-
-----------------------------------------------------------------
---   graph maps
-----------------------------------------------------------------
-
-cmmMapGraph    :: (g -> g') -> GenCmmGroup d h g -> GenCmmGroup d h g'
-cmmMapGraph f tops = map (cmmTopMapGraph f) tops
-
-cmmTopMapGraph :: (g -> g') -> GenCmmDecl d h g -> GenCmmDecl d h g'
-cmmTopMapGraph f (CmmProc h l v g) = CmmProc h l v (f g)
-cmmTopMapGraph _ (CmmData s ds)    = CmmData s ds
-
------------------------------------------------------------------------------
---              CmmStmt
--- A "statement".  Note that all branches are explicit: there are no
--- control transfers to computed addresses, except when transfering
--- control to a new function.
------------------------------------------------------------------------------
-
-data CmmStmt
-  = CmmNop
-  | CmmComment FastString
-
-  | CmmAssign CmmReg CmmExpr      -- Assign to register
-
-  | CmmStore CmmExpr CmmExpr      -- Assign to memory location. Size is
-                                  -- given by cmmExprType of the rhs.
-
-  | CmmCall                       -- A call (foreign, native or primitive), with
-      CmmCallTarget
-      [HintedCmmFormal]            -- zero or more results
-      [HintedCmmActual]            -- zero or more arguments
-      New.CmmReturnInfo
-      -- Some care is necessary when handling the arguments of these, see
-      -- [Register parameter passing] and the hack in cmm/CmmOpt.hs
-
-  | CmmBranch BlockId             -- branch to another BB in this fn
-
-  | CmmCondBranch CmmExpr BlockId -- conditional branch
-
-  | CmmSwitch                     -- Table branch
-      CmmExpr                       -- The scrutinee is zero-based;
-      [Maybe BlockId]               --      zero -> first block
-                                    --      one  -> second block etc
-                                    -- Undefined outside range, and when
-                                    -- there's a Nothing
-
-  | CmmJump                       -- Jump to another C-- function,
-      CmmExpr                       -- Target
-      [GlobalReg]                   -- Live registers at call site;
-                                    --      Nothing -> no information, assume
-                                    --                 all live
-                                    --      Just .. -> info on liveness, []
-                                    --                 means no live registers
-                                    -- This isn't all 'live' registers, just
-                                    -- the argument STG registers that are live
-                                    -- AND also possibly mapped to machine
-                                    -- registers. (So Sp, Hp, HpLim... ect
-                                    -- are never included here as they are
-                                    -- always live, only R2.., D1.. are
-                                    -- on this list)
-
-  | CmmReturn                     -- Return from a native C-- function,
-
-data CmmHinted a
-  = CmmHinted {
-        hintlessCmm :: a,
-        cmmHint :: New.ForeignHint
-    }
-  deriving( Eq )
-
-type HintedCmmFormal = CmmHinted CmmFormal
-type HintedCmmActual = CmmHinted CmmActual
-
-data CmmSafety
-  = CmmUnsafe
-  | CmmSafe New.C_SRT
-  | CmmInterruptible
-
--- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]'
-instance UserOfRegs LocalReg CmmStmt where
-  foldRegsUsed dflags f (set::b) s = stmt s set
-    where
-      stmt :: CmmStmt -> b -> b
-      stmt (CmmNop)                  = id
-      stmt (CmmComment {})           = id
-      stmt (CmmAssign _ e)           = gen e
-      stmt (CmmStore e1 e2)          = gen e1 . gen e2
-      stmt (CmmCall target _ es _)   = gen target . gen es
-      stmt (CmmBranch _)             = id
-      stmt (CmmCondBranch e _)       = gen e
-      stmt (CmmSwitch e _)           = gen e
-      stmt (CmmJump e _)             = gen e
-      stmt (CmmReturn)               = id
-
-      gen :: UserOfRegs LocalReg a => a -> b -> b
-      gen a set = foldRegsUsed dflags f set a
-
-instance UserOfRegs LocalReg CmmCallTarget where
-    foldRegsUsed dflags f set (CmmCallee e _)    = foldRegsUsed dflags f set e
-    foldRegsUsed dflags f set (CmmPrim _ mStmts) = foldRegsUsed dflags f set mStmts
-
-instance UserOfRegs r a => UserOfRegs r (CmmHinted a) where
-    foldRegsUsed dflags f set a = foldRegsUsed dflags f set (hintlessCmm a)
-
-instance DefinerOfRegs r a => DefinerOfRegs r (CmmHinted a) where
-    foldRegsDefd dflags f set a = foldRegsDefd dflags f set (hintlessCmm a)
-
-{-
-Discussion
-~~~~~~~~~~
-
-One possible problem with the above type is that the only way to do a
-non-local conditional jump is to encode it as a branch to a block that
-contains a single jump.  This leads to inefficient code in the back end.
-
-[N.B. This problem will go away when we make the transition to the
-'zipper' form of control-flow graph, in which both targets of a
-conditional jump are explicit. ---NR]
-
-One possible way to fix this would be:
-
-data CmmStat =
-  ...
-  | CmmJump CmmBranchDest
-  | CmmCondJump CmmExpr CmmBranchDest
-  ...
-
-data CmmBranchDest
-  = Local BlockId
-  | NonLocal CmmExpr [LocalReg]
-
-In favour:
-
-+ one fewer constructors in CmmStmt
-+ allows both cond branch and switch to jump to non-local destinations
-
-Against:
-
-- not strictly necessary: can already encode as branch+jump
-- not always possible to implement any better in the back end
-- could do the optimisation in the back end (but then plat-specific?)
-- C-- doesn't have it
-- back-end optimisation might be more general (jump shortcutting)
-
-So we'll stick with the way it is, and add the optimisation to the NCG.
--}
-
------------------------------------------------------------------------------
---              CmmCallTarget
---
--- The target of a CmmCall.
------------------------------------------------------------------------------
-
-data CmmCallTarget
-  = CmmCallee           -- Call a function (foreign or native)
-        CmmExpr                 -- literal label <=> static call
-                                -- other expression <=> dynamic call
-        CCallConv               -- The calling convention
-
-  | CmmPrim             -- Call a "primitive" (eg. sin, cos)
-        CallishMachOp           -- These might be implemented as inline
-                                -- code by the backend.
-        -- If we don't know how to implement the
-        -- mach op, then we can replace it with
-        -- this list of statements:
-        (Maybe [CmmStmt])
-
diff --git a/compiler/cmm/OldCmmLint.hs b/compiler/cmm/OldCmmLint.hs
deleted file mode 100644
index 9a4fb42bc5..0000000000
--- a/compiler/cmm/OldCmmLint.hs
+++ /dev/null
@@ -1,212 +0,0 @@
------------------------------------------------------------------------------
---
--- (c) The University of Glasgow 2004-2006
---
--- CmmLint: checking the correctness of Cmm statements and expressions
---
------------------------------------------------------------------------------
-
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
-module OldCmmLint (
-  cmmLint, cmmLintTop
-  ) where
-
-import BlockId
-import OldCmm
-import Outputable
-import OldPprCmm()
-import FastString
-import DynFlags
-
-import Data.Maybe
-
--- -----------------------------------------------------------------------------
--- Exported entry points:
-
-cmmLint :: (Outputable d, Outputable h)
-        => DynFlags -> GenCmmGroup d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLint dflags tops = runCmmLint dflags (mapM_ (lintCmmDecl dflags)) tops
-
-cmmLintTop :: (Outputable d, Outputable h)
-           => DynFlags -> GenCmmDecl d h (ListGraph CmmStmt) -> Maybe SDoc
-cmmLintTop dflags top = runCmmLint dflags (lintCmmDecl dflags) top
-
-runCmmLint :: Outputable a
-           => DynFlags -> (a -> CmmLint b) -> a -> Maybe SDoc
-runCmmLint _ l p =
-   case unCL (l p) of
-   Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"),
-                           nest 2 err,
-                           ptext $ sLit ("Program was:"),
-                           nest 2 (ppr p)])
-   Right _  -> Nothing
-
-lintCmmDecl :: DynFlags -> (GenCmmDecl h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmDecl dflags (CmmProc _ lbl _ (ListGraph blocks))
-  = addLintInfo (text "in proc " <> ppr lbl) $
-        let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
-        in  mapM_ (lintCmmBlock dflags labels) blocks
-
-lintCmmDecl _ (CmmData {})
-  = return ()
-
-lintCmmBlock :: DynFlags -> BlockSet -> GenBasicBlock CmmStmt -> CmmLint ()
-lintCmmBlock dflags labels (BasicBlock id stmts)
-  = addLintInfo (text "in basic block " <> ppr id) $
-	mapM_ (lintCmmStmt dflags labels) stmts
-
--- -----------------------------------------------------------------------------
--- lintCmmExpr
-
--- Checks whether a CmmExpr is "type-correct", and check for obvious-looking
--- byte/word mismatches.
-
-lintCmmExpr :: DynFlags -> CmmExpr -> CmmLint CmmType
-lintCmmExpr dflags (CmmLoad expr rep) = do
-  _ <- lintCmmExpr dflags expr
-  -- Disabled, if we have the inlining phase before the lint phase,
-  -- we can have funny offsets due to pointer tagging. -- EZY
-  -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
-  --   cmmCheckWordAddress expr
-  return rep
-lintCmmExpr dflags expr@(CmmMachOp op args) = do
-  tys <- mapM (lintCmmExpr dflags) args
-  if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
-  	then cmmCheckMachOp dflags op args tys
-	else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
-lintCmmExpr dflags (CmmRegOff reg offset)
-  = lintCmmExpr dflags (CmmMachOp (MO_Add rep)
-		[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
-  where rep = typeWidth (cmmRegType dflags reg)
-lintCmmExpr dflags expr =
-  return (cmmExprType dflags expr)
-
--- Check for some common byte/word mismatches (eg. Sp + 1)
-cmmCheckMachOp   :: DynFlags -> MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
-cmmCheckMachOp dflags op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
-  = cmmCheckMachOp dflags op [reg, lit] tys
-cmmCheckMachOp dflags op _ tys
-  = return (machOpResultType dflags op tys)
-
-{-
-isOffsetOp :: MachOp -> Bool
-isOffsetOp (MO_Add _) = True
-isOffsetOp (MO_Sub _) = True
-isOffsetOp _ = False
-
--- This expression should be an address from which a word can be loaded:
--- check for funny-looking sub-word offsets.
-_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
-_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
-  = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
-  | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
-  = cmmLintDubiousWordOffset e
-_cmmCheckWordAddress _
-  = return ()
-
--- No warnings for unaligned arithmetic with the node register,
--- which is used to extract fields from tagged constructor closures.
-notNodeReg :: CmmExpr -> Bool
-notNodeReg (CmmReg reg) | reg == nodeReg = False
-notNodeReg _                             = True
--}
-
-lintCmmStmt :: DynFlags -> BlockSet -> CmmStmt -> CmmLint ()
-lintCmmStmt dflags labels = lint
-    where lint (CmmNop) = return ()
-          lint (CmmComment {}) = return ()
-          lint stmt@(CmmAssign reg expr) = do
-            erep <- lintCmmExpr dflags expr
-            let reg_ty = cmmRegType dflags reg
-            if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
-                then return ()
-                else cmmLintAssignErr stmt erep reg_ty
-          lint (CmmStore l r) = do
-            _ <- lintCmmExpr dflags l
-            _ <- lintCmmExpr dflags r
-            return ()
-          lint (CmmCall target _res args _) =
-              do lintTarget dflags labels target
-                 mapM_ (lintCmmExpr dflags . hintlessCmm) args
-          lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr dflags e >> checkCond dflags e
-          lint (CmmSwitch e branches) = do
-            mapM_ checkTarget $ catMaybes branches
-            erep <- lintCmmExpr dflags e
-            if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
-              then return ()
-              else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e <>
-                               text " :: " <> ppr erep)
-          lint (CmmJump e _) = lintCmmExpr dflags e >> return ()
-          lint (CmmReturn) = return ()
-          lint (CmmBranch id)    = checkTarget id
-          checkTarget id = if setMember id labels then return ()
-                           else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
-
-lintTarget :: DynFlags -> BlockSet -> CmmCallTarget -> CmmLint ()
-lintTarget dflags _      (CmmCallee e _) = do _ <- lintCmmExpr dflags e
-                                              return ()
-lintTarget _      _      (CmmPrim _ Nothing) = return ()
-lintTarget dflags labels (CmmPrim _ (Just stmts))
-    = mapM_ (lintCmmStmt dflags labels) stmts
-
-
-checkCond :: DynFlags -> CmmExpr -> CmmLint ()
-checkCond _      (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
-checkCond _      expr
-    = cmmLintErr (hang (text "expression is not a conditional:") 2
-                       (ppr expr))
-
--- -----------------------------------------------------------------------------
--- CmmLint monad
-
--- just a basic error monad:
-
-newtype CmmLint a = CmmLint { unCL :: Either SDoc a }
-
-instance Monad CmmLint where
-  CmmLint m >>= k = CmmLint $ case m of 
-				Left e -> Left e
-				Right a -> unCL (k a)
-  return a = CmmLint (Right a)
-
-cmmLintErr :: SDoc -> CmmLint a
-cmmLintErr msg = CmmLint (Left msg)
-
-addLintInfo :: SDoc -> CmmLint a -> CmmLint a
-addLintInfo info thing = CmmLint $ 
-   case unCL thing of
-	Left err -> Left (hang info 2 err)
-	Right a  -> Right a
-
-cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
-cmmLintMachOpErr expr argsRep opExpectsRep
-     = cmmLintErr (text "in MachOp application: " $$ 
-					nest 2 (ppr expr) $$
-				        (text "op is expecting: " <+> ppr opExpectsRep) $$
-					(text "arguments provide: " <+> ppr argsRep))
-
-cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
-cmmLintAssignErr stmt e_ty r_ty
-  = cmmLintErr (text "in assignment: " $$ 
-		nest 2 (vcat [ppr stmt, 
-			      text "Reg ty:" <+> ppr r_ty,
-			      text "Rhs ty:" <+> ppr e_ty]))
-			 
-					
-
-{-
-cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
-cmmLintDubiousWordOffset expr
-   = cmmLintErr (text "offset is not a multiple of words: " $$
-			nest 2 (ppr expr))
--}
-
diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs
deleted file mode 100644
index fe6ccee642..0000000000
--- a/compiler/cmm/OldCmmUtils.hs
+++ /dev/null
@@ -1,100 +0,0 @@
------------------------------------------------------------------------------
---
--- Old-style Cmm utilities.
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module OldCmmUtils(
-        CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
-        isNopStmt,
-
-        maybeAssignTemp, loadArgsIntoTemps,
-
-        module CmmUtils,
-  ) where
-
-#include "HsVersions.h"
-
-import OldCmm
-import CmmUtils
-import OrdList
-import DynFlags
-import Unique
-
----------------------------------------------------
---
---      CmmStmts
---
----------------------------------------------------
-
-type CmmStmts = OrdList CmmStmt
-
-noStmts :: CmmStmts
-noStmts = nilOL
-
-oneStmt :: CmmStmt -> CmmStmts
-oneStmt = unitOL
-
-mkStmts :: [CmmStmt] -> CmmStmts
-mkStmts = toOL
-
-plusStmts :: CmmStmts -> CmmStmts -> CmmStmts
-plusStmts = appOL
-
-stmtList :: CmmStmts -> [CmmStmt]
-stmtList = fromOL
-
-
----------------------------------------------------
---
---      CmmStmt
---
----------------------------------------------------
-
-isNopStmt :: CmmStmt -> Bool
--- If isNopStmt returns True, the stmt is definitely a no-op;
--- but it might be a no-op even if isNopStmt returns False
-isNopStmt CmmNop                       = True
-isNopStmt (CmmAssign r e)              = cheapEqReg r e
-isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2
-isNopStmt _                            = False
-
-cheapEqExpr :: CmmExpr -> CmmExpr -> Bool
-cheapEqExpr (CmmReg r)      e                 = cheapEqReg r e
-cheapEqExpr (CmmRegOff r 0) e                 = cheapEqReg r e
-cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n'
-cheapEqExpr _               _                 = False
-
-cheapEqReg :: CmmReg -> CmmExpr -> Bool
-cheapEqReg r (CmmReg r')      = r==r'
-cheapEqReg r (CmmRegOff r' 0) = r==r'
-cheapEqReg _ _                = False
-
----------------------------------------------------
---
---      Helpers for foreign call arguments
---
----------------------------------------------------
-
-loadArgsIntoTemps :: DynFlags -> [Unique]
-                  -> [HintedCmmActual]
-                  -> ([Unique], [CmmStmt], [HintedCmmActual])
-loadArgsIntoTemps _      uniques [] = (uniques, [], [])
-loadArgsIntoTemps dflags uniques ((CmmHinted e hint):args) =
-    (uniques'',
-     new_stmts ++ remaining_stmts,
-     (CmmHinted new_e hint) : remaining_e)
-    where
-      (uniques', new_stmts, new_e) = maybeAssignTemp dflags uniques e
-      (uniques'', remaining_stmts, remaining_e) =
-          loadArgsIntoTemps dflags uniques' args
-
-
-maybeAssignTemp :: DynFlags -> [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr)
-maybeAssignTemp dflags uniques e
-    | hasNoGlobalRegs e = (uniques, [], e)
-    | otherwise         = (tail uniques, [CmmAssign local e], CmmReg local)
-    where local = CmmLocal (LocalReg (head uniques) (cmmExprType dflags e))
-
diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs
deleted file mode 100644
index edfaef8098..0000000000
--- a/compiler/cmm/OldPprCmm.hs
+++ /dev/null
@@ -1,224 +0,0 @@
-----------------------------------------------------------------------------
---
--- Pretty-printing of old-style Cmm as (a superset of) C--
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
---
--- This is where we walk over Cmm emitting an external representation,
--- suitable for parsing, in a syntax strongly reminiscent of C--. This
--- is the "External Core" for the Cmm layer.
---
--- As such, this should be a well-defined syntax: we want it to look nice.
--- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cminusminus.org/. We differ
--- slightly, in some cases. For one, we use I8 .. I64 for types, rather
--- than C--'s bits8 .. bits64.
---
--- We try to ensure that all information available in the abstract
--- syntax is reproduced, or reproducible, in the concrete syntax.
--- Data that is not in printed out can be reconstructed according to
--- conventions used in the pretty printer. There are at least two such
--- cases:
---      1) if a value has wordRep type, the type is not appended in the
---      output.
---      2) MachOps that operate over wordRep type are printed in a
---      C-style, rather than as their internal MachRep name.
---
--- These conventions produce much more readable Cmm output.
---
--- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
---
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module OldPprCmm (
-        pprStmt,
-        module PprCmmDecl,
-        module PprCmmExpr
-    ) where
-
-import BlockId
-import CLabel
-import CmmUtils
-import OldCmm
-import PprCmmDecl
-import PprCmmExpr
-
-import BasicTypes
-import ForeignCall
-import Outputable
-import FastString
-
-import Data.List
-
------------------------------------------------------------------------------
-
-instance Outputable instr => Outputable (ListGraph instr) where
-    ppr (ListGraph blocks) = vcat (map ppr blocks)
-
-instance Outputable instr => Outputable (GenBasicBlock instr) where
-    ppr = pprBBlock
-
-instance Outputable CmmStmt where
-    ppr s = pprStmt s
-
--- --------------------------------------------------------------------------
-instance Outputable CmmSafety where
-  ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
-  ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
-  ppr (CmmSafe srt) = ppr srt
-
--- --------------------------------------------------------------------------
--- Basic blocks look like assembly blocks.
---      lbl: stmt ; stmt ; ..
-pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
-pprBBlock (BasicBlock ident stmts) =
-    hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-
--- --------------------------------------------------------------------------
--- Statements. C-- usually, exceptions to this should be obvious.
---
-pprStmt :: CmmStmt -> SDoc
-pprStmt stmt = case stmt of
-
-    -- ;
-    CmmNop -> semi
-
-    -- // text
-    CmmComment s -> text "//" <+> ftext s
-
-    -- reg = expr;
-    CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-
-    -- rep[lv] = expr;
-    CmmStore lv expr ->
-        sdocWithDynFlags $ \dflags ->
-        let rep = ppr ( cmmExprType dflags expr )
-        in rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
-
-    -- call "ccall" foo(x, y)[r1, r2];
-    -- ToDo ppr volatile
-    CmmCall (CmmCallee fn cconv) results args ret ->
-        sep  [ pp_lhs <+> pp_conv
-             , nest 2 (pprExpr9 fn <>
-                       parens (commafy (map ppr_ar args)))
-             , case ret of CmmMayReturn -> empty
-                           CmmNeverReturns -> ptext $ sLit (" never returns")
-             ] <> semi
-        where
-          pp_lhs | null results = empty
-                 | otherwise    = commafy (map ppr_ar results) <+> equals
-                -- Don't print the hints on a native C-- call
-          ppr_ar (CmmHinted ar k) = ppr (ar,k)
-          pp_conv = ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
-
-    -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
-    CmmCall (CmmPrim op _) results args ret ->
-        pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) results args ret)
-        where
-          -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
-          --       use one to get the label printed.
-          lbl = CmmLabel (mkForeignLabel
-                                (mkFastString (show op))
-                                Nothing ForeignLabelInThisPackage IsFunction)
-
-    CmmBranch ident          -> genBranch ident
-    CmmCondBranch expr ident -> genCondBranch expr ident
-    CmmJump expr live        -> genJump expr live
-    CmmReturn                -> genReturn
-    CmmSwitch arg ids        -> genSwitch arg ids
-
--- Just look like a tuple, since it was a tuple before
--- ... is that a good idea? --Isaac Dupree
-instance (Outputable a) => Outputable (CmmHinted a) where
-  ppr (CmmHinted a k) = ppr (a, k)
-
--- --------------------------------------------------------------------------
--- goto local label. [1], section 6.6
---
---     goto lbl;
---
-genBranch :: BlockId -> SDoc
-genBranch ident =
-    ptext (sLit "goto") <+> ppr ident <> semi
-
--- --------------------------------------------------------------------------
--- Conditional. [1], section 6.4
---
---     if (expr) { goto lbl; }
---
-genCondBranch :: CmmExpr -> BlockId -> SDoc
-genCondBranch expr ident =
-    hsep [ ptext (sLit "if")
-         , parens (ppr expr)
-         , ptext (sLit "goto")
-         , ppr ident <> semi ]
-
--- --------------------------------------------------------------------------
--- A tail call. [1], Section 6.9
---
---     jump foo(a, b, c);
---
-genJump :: CmmExpr -> [GlobalReg] -> SDoc
-genJump expr live =
-    hcat [ ptext (sLit "jump")
-         , space
-         , if isTrivialCmmExpr expr
-                then pprExpr expr
-                else case expr of
-                    CmmLoad (CmmReg _) _ -> pprExpr expr
-                    _                    -> parens (pprExpr expr)
-         , semi <+> ptext (sLit "// ")
-         , ppr live]
-
--- --------------------------------------------------------------------------
--- Return from a function. [1], Section 6.8.2 of version 1.128
---
---     return (a, b, c);
---
-genReturn :: SDoc
-genReturn = hcat [ ptext (sLit "return") , semi ]
-
--- --------------------------------------------------------------------------
--- Tabled jump to local label
---
--- The syntax is from [1], section 6.5
---
---      switch [0 .. n] (expr) { case ... ; }
---
-genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
-genSwitch expr maybe_ids
-
-    = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
-
-      in hang (hcat [ ptext (sLit "switch [0 .. ")
-                    , int (length maybe_ids - 1)
-                    , ptext (sLit "] ")
-                    , if isTrivialCmmExpr expr
-                        then pprExpr expr
-                        else parens (pprExpr expr)
-                    , ptext (sLit " {")
-                    ])
-            4 (vcat ( map caseify pairs )) $$ rbrace
-
-    where
-      snds a b = (snd a) == (snd b)
-
-      caseify :: [(Int,Maybe BlockId)] -> SDoc
-      caseify ixs@((_,Nothing):_)
-        = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
-                <> ptext (sLit " */")
-      caseify as
-        = let (is,ids) = unzip as
-          in hsep [ ptext (sLit "case")
-                  , hcat (punctuate comma (map int is))
-                  , ptext (sLit ": goto")
-                  , ppr (head [ id | Just id <- ids]) <> semi ]
-
------------------------------------------------------------------------------
-
-commafy :: [SDoc] -> SDoc
-commafy xs = fsep $ punctuate comma xs
-
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index e0ff99cb29..ee964d8701 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -16,6 +16,7 @@
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE GADTs #-}
 module PprC (
         writeCs,
         pprStringInCStyle
@@ -27,8 +28,10 @@ module PprC (
 import BlockId
 import CLabel
 import ForeignCall
-import OldCmm
-import OldPprCmm ()
+import Cmm hiding (pprBBlock)
+import PprCmm ()
+import Hoopl
+import CmmUtils
 
 -- Utils
 import CPrim
@@ -81,8 +84,9 @@ pprC tops = vcat $ intersperse blankLine $ map pprTop tops
 -- top level procs
 --
 pprTop :: RawCmmDecl -> SDoc
-pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) =
-    (case topInfoTable proc of
+pprTop (CmmProc infos clbl _ graph) =
+
+    (case mapLookup (g_entry graph) infos of
        Nothing -> empty
        Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$
                                             pprWordArray info_clbl info_dat) $$
@@ -93,16 +97,12 @@ pprTop proc@(CmmProc _ clbl _ (ListGraph blocks)) =
                     then mkFN_ else mkIF_) (ppr clbl) <+> lbrace,
            nest 8 temp_decls,
            nest 8 mkFB_,
-           case blocks of
-               [] -> empty
-               -- the first block doesn't get a label:
-               (BasicBlock _ stmts : rest) ->
-                    nest 8 (vcat (map pprStmt stmts)) $$
-                       vcat (map pprBBlock rest),
+           vcat (map pprBBlock blocks),
            nest 8 mkFE_,
            rbrace ]
     )
   where
+        blocks = toBlockList graph
         (temp_decls, extern_decls) = pprTempAndExternDecls blocks
 
 
@@ -133,14 +133,12 @@ pprTop (CmmData _section (Statics lbl lits)) =
 -- as many jumps as possible into fall throughs.
 --
 
-pprBBlock :: CmmBasicBlock -> SDoc
-pprBBlock (BasicBlock lbl stmts) =
-    if null stmts then
-        pprTrace "pprC.pprBBlock: curious empty code block for"
-                        (pprBlockId lbl) empty
-    else
-        nest 4 (pprBlockId lbl <> colon) $$
-        nest 8 (vcat (map pprStmt stmts))
+pprBBlock :: CmmBlock -> SDoc
+pprBBlock block =
+  nest 4 (pprBlockId lbl <> colon) $$
+  nest 8 (vcat (map pprStmt (blockToList nodes)) $$ pprStmt last)
+ where
+  (CmmEntry lbl, nodes, last)  = blockSplit block
 
 -- --------------------------------------------------------------------------
 -- Info tables. Just arrays of words.
@@ -165,13 +163,11 @@ pprLocalness lbl | not $ externallyVisibleCLabel lbl = ptext (sLit "static ")
 -- Statements.
 --
 
-pprStmt :: CmmStmt -> SDoc
+pprStmt :: CmmNode e x -> SDoc
 
 pprStmt stmt =
     sdocWithDynFlags $ \dflags ->
     case stmt of
-    CmmReturn    -> panic "pprStmt: return statement should have been cps'd away"
-    CmmNop       -> empty
     CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/")
                           -- XXX if the string contains "*/", we need to fix it
                           -- XXX we probably want to emit these comments when
@@ -191,14 +187,20 @@ pprStmt stmt =
         where
           rep = cmmExprType dflags src
 
-    CmmCall (CmmCallee fn cconv) results args ret ->
+    CmmUnsafeForeignCall target@(ForeignTarget fn conv) results args ->
         maybe_proto $$
         fnCall
         where
-        cast_fn = parens (cCast (pprCFunType (char '*') cconv results args) fn)
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
+        ForeignConvention cconv _ _ ret = conv
+
+        cast_fn = parens (cCast (pprCFunType (char '*') cconv hresults hargs) fn)
 
         real_fun_proto lbl = char ';' <>
-                        pprCFunType (ppr lbl) cconv results args <>
+                        pprCFunType (ppr lbl) cconv hresults hargs <>
                         noreturn_attr <> semi
 
         noreturn_attr = case ret of
@@ -210,7 +212,7 @@ pprStmt stmt =
             case fn of
               CmmLit (CmmLabel lbl)
                 | StdCallConv <- cconv ->
-                    let myCall = pprCall (ppr lbl) cconv results args
+                    let myCall = pprCall (ppr lbl) cconv hresults hargs
                     in (real_fun_proto lbl, myCall)
                         -- stdcall functions must be declared with
                         -- a function type, otherwise the C compiler
@@ -218,40 +220,44 @@ pprStmt stmt =
                         -- can't add the @n suffix ourselves, because
                         -- it isn't valid C.
                 | CmmNeverReturns <- ret ->
-                    let myCall = pprCall (ppr lbl) cconv results args
+                    let myCall = pprCall (ppr lbl) cconv hresults hargs
                     in (real_fun_proto lbl, myCall)
                 | not (isMathFun lbl) ->
-                    pprForeignCall (ppr lbl) cconv results args
+                    pprForeignCall (ppr lbl) cconv hresults hargs
               _ ->
                    (empty {- no proto -},
-                    pprCall cast_fn cconv results args <> semi)
+                    pprCall cast_fn cconv hresults hargs <> semi)
                         -- for a dynamic call, no declaration is necessary.
 
-    CmmCall (CmmPrim _ (Just stmts)) _ _ _ ->
-        vcat $ map pprStmt stmts
-
-    CmmCall (CmmPrim op _) results args _ret ->
+    CmmUnsafeForeignCall target@(PrimTarget op) results args ->
         proto $$ fn_call
       where
         cconv = CCallConv
         fn = pprCallishMachOp_for_C op
+
+        (res_hints, arg_hints) = foreignTargetHints target
+        hresults = zip results res_hints
+        hargs    = zip args arg_hints
+
         (proto, fn_call)
           -- The mem primops carry an extra alignment arg, must drop it.
           -- We could maybe emit an alignment directive using this info.
           -- We also need to cast mem primops to prevent conflicts with GCC
           -- builtins (see bug #5967).
           | op `elem` [MO_Memcpy, MO_Memset, MO_Memmove]
-          = pprForeignCall fn cconv results (init args)
+          = pprForeignCall fn cconv hresults (init hargs)
           | otherwise
-          = (empty, pprCall fn cconv results args)
+          = (empty, pprCall fn cconv hresults hargs)
 
     CmmBranch ident          -> pprBranch ident
-    CmmCondBranch expr ident -> pprCondBranch expr ident
-    CmmJump lbl _            -> mkJMP_(pprExpr lbl) <> semi
+    CmmCondBranch expr yes no -> pprCondBranch expr yes no
+    CmmCall { cml_target = expr } -> mkJMP_ (pprExpr expr) <> semi
     CmmSwitch arg ids        -> sdocWithDynFlags $ \dflags ->
                                 pprSwitch dflags arg ids
 
-pprForeignCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual]
+type Hinted a = (a, ForeignHint)
+
+pprForeignCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual]
                -> (SDoc, SDoc)
 pprForeignCall fn cconv results args = (proto, fn_call)
   where
@@ -263,14 +269,14 @@ pprForeignCall fn cconv results args = (proto, fn_call)
     cast_fn = parens (parens (pprCFunType (char '*') cconv results args) <> fn)
     proto = ptext (sLit ";EF_(") <> fn <> char ')' <> semi
 
-pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
+pprCFunType :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
 pprCFunType ppr_fn cconv ress args
   = sdocWithDynFlags $ \dflags ->
     let res_type [] = ptext (sLit "void")
-        res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint
+        res_type [(one, hint)] = machRepHintCType (localRegType one) hint
         res_type _ = panic "pprCFunType: only void or 1 return value supported"
 
-        arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType dflags expr) hint
+        arg_type (expr, hint) = machRepHintCType (cmmExprType dflags expr) hint
     in res_type ress <+>
        parens (ccallConvAttribute cconv <> ppr_fn) <>
        parens (commafy (map arg_type args))
@@ -283,11 +289,11 @@ pprBranch ident = ptext (sLit "goto") <+> pprBlockId ident <> semi
 
 -- ---------------------------------------------------------------------
 -- conditional branches to local labels
-pprCondBranch :: CmmExpr -> BlockId -> SDoc
-pprCondBranch expr ident
+pprCondBranch :: CmmExpr -> BlockId -> BlockId -> SDoc
+pprCondBranch expr yes no
         = hsep [ ptext (sLit "if") , parens(pprExpr expr) ,
-                        ptext (sLit "goto") , (pprBlockId ident) <> semi ]
-
+                        ptext (sLit "goto"), pprBlockId yes,
+                        ptext (sLit "else"), pprBlockId no <> semi ]
 
 -- ---------------------------------------------------------------------
 -- a local table branch
@@ -831,7 +837,7 @@ pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq
 -- -----------------------------------------------------------------------------
 -- Foreign Calls
 
-pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc
+pprCall :: SDoc -> CCallConv -> [Hinted CmmFormal] -> [Hinted CmmActual] -> SDoc
 pprCall ppr_fn cconv results args
   | not (is_cishCC cconv)
   = panic $ "pprCall: unknown calling convention"
@@ -841,18 +847,18 @@ pprCall ppr_fn cconv results args
     ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi
   where
      ppr_assign []           rhs = rhs
-     ppr_assign [CmmHinted one hint] rhs
+     ppr_assign [(one,hint)] rhs
          = pprLocalReg one <> ptext (sLit " = ")
                  <> pprUnHint hint (localRegType one) <> rhs
      ppr_assign _other _rhs = panic "pprCall: multiple results"
 
-     pprArg (CmmHinted expr AddrHint)
+     pprArg (expr, AddrHint)
         = cCast (ptext (sLit "void *")) expr
         -- see comment by machRepHintCType below
-     pprArg (CmmHinted expr SignedHint)
+     pprArg (expr, SignedHint)
         = sdocWithDynFlags $ \dflags ->
           cCast (machRep_S_CType $ typeWidth $ cmmExprType dflags expr) expr
-     pprArg (CmmHinted expr _other)
+     pprArg (expr, _other)
         = pprExpr expr
 
      pprUnHint AddrHint   rep = parens (machRepCType rep)
@@ -871,7 +877,7 @@ is_cishCC PrimCallConv = False
 -- Find and print local and external declarations for a list of
 -- Cmm statements.
 --
-pprTempAndExternDecls :: [CmmBasicBlock] -> (SDoc{-temps-}, SDoc{-externs-})
+pprTempAndExternDecls :: [CmmBlock] -> (SDoc{-temps-}, SDoc{-externs-})
 pprTempAndExternDecls stmts
   = (vcat (map pprTempDecl (uniqSetToList temps)),
      vcat (map (pprExternDecl False{-ToDo-}) (Map.keys lbls)))
@@ -930,8 +936,9 @@ te_Static :: CmmStatic -> TE ()
 te_Static (CmmStaticLit lit) = te_Lit lit
 te_Static _ = return ()
 
-te_BB :: CmmBasicBlock -> TE ()
-te_BB (BasicBlock _ ss)         = mapM_ te_Stmt ss
+te_BB :: CmmBlock -> TE ()
+te_BB block = mapM_ te_Stmt (blockToList mid) >> te_Stmt last
+  where (_, mid, last) = blockSplit block
 
 te_Lit :: CmmLit -> TE ()
 te_Lit (CmmLabel l) = te_lbl l
@@ -939,21 +946,21 @@ te_Lit (CmmLabelOff l _) = te_lbl l
 te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1
 te_Lit _ = return ()
 
-te_Stmt :: CmmStmt -> TE ()
+te_Stmt :: CmmNode e x -> TE ()
 te_Stmt (CmmAssign r e)         = te_Reg r >> te_Expr e
 te_Stmt (CmmStore l r)          = te_Expr l >> te_Expr r
-te_Stmt (CmmCall target rs es _) = do te_Target target
-                                      mapM_ (te_temp.hintlessCmm) rs
-                                      mapM_ (te_Expr.hintlessCmm) es
-te_Stmt (CmmCondBranch e _)     = te_Expr e
+te_Stmt (CmmUnsafeForeignCall target rs es)
+  = do  te_Target target
+        mapM_ te_temp rs
+        mapM_ te_Expr es
+te_Stmt (CmmCondBranch e _ _)   = te_Expr e
 te_Stmt (CmmSwitch e _)         = te_Expr e
-te_Stmt (CmmJump e _)           = te_Expr e
+te_Stmt (CmmCall { cml_target = e }) = te_Expr e
 te_Stmt _                       = return ()
 
-te_Target :: CmmCallTarget -> TE ()
-te_Target (CmmCallee {})           = return ()
-te_Target (CmmPrim _ Nothing)      = return ()
-te_Target (CmmPrim _ (Just stmts)) = mapM_ te_Stmt stmts
+te_Target :: ForeignTarget -> TE ()
+te_Target (ForeignTarget e _)      = te_Expr e
+te_Target (PrimTarget{})           = return ()
 
 te_Expr :: CmmExpr -> TE ()
 te_Expr (CmmLit lit)            = te_Lit lit
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs
index 7d2f4824ef..71c84464ad 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/cmm/PprCmmExpr.hs
@@ -35,7 +35,6 @@
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 module PprCmmExpr
     ( pprExpr, pprLit
-    , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -}
     )
 where