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.

5 files changed, 44 insertions, 36 deletions

diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs
index 848c7f933c..5e05047f34 100644
--- a/compiler/nativeGen/PPC/CodeGen.hs
+++ b/compiler/nativeGen/PPC/CodeGen.hs
@@ -12,6 +12,7 @@
 -- (c) the #if blah_TARGET_ARCH} things, the
 -- structure should not be too overwhelming.
 
+{-# LANGUAGE GADTs #-}
 module PPC.CodeGen (
         cmmTopCodeGen,
         generateJumpTableForInstr,
@@ -42,8 +43,10 @@ import Platform
 -- Our intermediate code:
 import BlockId
 import PprCmm           ( pprExpr )
-import OldCmm
+import Cmm
+import CmmUtils
 import CLabel
+import Hoopl
 
 -- The rest:
 import OrdList
@@ -71,7 +74,8 @@ cmmTopCodeGen
         :: RawCmmDecl
         -> NatM [NatCmmDecl CmmStatics Instr]
 
-cmmTopCodeGen (CmmProc info lab live (ListGraph blocks)) = do
+cmmTopCodeGen (CmmProc info lab live graph) = do
+  let blocks = toBlockListEntryFirst graph
   (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
   picBaseMb <- getPicBaseMaybeNat
   dflags <- getDynFlags
@@ -86,12 +90,16 @@ cmmTopCodeGen (CmmData sec dat) = do
   return [CmmData sec dat]  -- no translation, we just use CmmStatic
 
 basicBlockCodeGen
-        :: CmmBasicBlock
+        :: Block CmmNode C C
         -> NatM ( [NatBasicBlock Instr]
                 , [NatCmmDecl CmmStatics Instr])
 
-basicBlockCodeGen (BasicBlock id stmts) = do
-  instrs <- stmtsToInstrs stmts
+basicBlockCodeGen block = do
+  let (CmmEntry id, nodes, tail)  = blockSplit block
+      stmts = blockToList nodes
+  mid_instrs <- stmtsToInstrs stmts
+  tail_instrs <- stmtToInstrs tail
+  let instrs = mid_instrs `appOL` tail_instrs
   -- code generation may introduce new basic block boundaries, which
   -- are indicated by the NEWBLOCK instruction.  We must split up the
   -- instruction stream into basic blocks again.  Also, we extract
@@ -107,16 +115,15 @@ basicBlockCodeGen (BasicBlock id stmts) = do
           = (instr:instrs, blocks, statics)
   return (BasicBlock id top : other_blocks, statics)
 
-stmtsToInstrs :: [CmmStmt] -> NatM InstrBlock
+stmtsToInstrs :: [CmmNode e x] -> NatM InstrBlock
 stmtsToInstrs stmts
    = do instrss <- mapM stmtToInstrs stmts
         return (concatOL instrss)
 
-stmtToInstrs :: CmmStmt -> NatM InstrBlock
+stmtToInstrs :: CmmNode e x -> NatM InstrBlock
 stmtToInstrs stmt = do
   dflags <- getDynFlags
   case stmt of
-    CmmNop         -> return nilOL
     CmmComment s   -> return (unitOL (COMMENT s))
 
     CmmAssign reg src
@@ -135,16 +142,18 @@ stmtToInstrs stmt = do
         where ty = cmmExprType dflags src
               size = cmmTypeSize ty
 
-    CmmCall target result_regs args _
+    CmmUnsafeForeignCall target result_regs args
        -> genCCall target result_regs args
 
     CmmBranch id          -> genBranch id
-    CmmCondBranch arg id  -> genCondJump id arg
+    CmmCondBranch arg true false -> do b1 <- genCondJump true arg
+                                       b2 <- genBranch false
+                                       return (b1 `appOL` b2)
     CmmSwitch arg ids     -> do dflags <- getDynFlags
                                 genSwitch dflags arg ids
-    CmmJump arg _         -> genJump arg
-    CmmReturn             ->
-      panic "stmtToInstrs: return statement should have been cps'd away"
+    CmmCall { cml_target = arg } -> genJump arg
+    _ ->
+      panic "stmtToInstrs: statement should have been cps'd away"
 
 
 --------------------------------------------------------------------------------
@@ -837,9 +846,9 @@ genCondJump id bool = do
 -- (If applicable) Do not fill the delay slots here; you will confuse the
 -- register allocator.
 
-genCCall :: CmmCallTarget            -- function to call
-         -> [HintedCmmFormal]        -- where to put the result
-         -> [HintedCmmActual]        -- arguments (of mixed type)
+genCCall :: ForeignTarget            -- function to call
+         -> [CmmFormal]        -- where to put the result
+         -> [CmmActual]        -- arguments (of mixed type)
          -> NatM InstrBlock
 genCCall target dest_regs argsAndHints
  = do dflags <- getDynFlags
@@ -854,9 +863,9 @@ data GenCCallPlatform = GCPLinux | GCPDarwin
 genCCall'
     :: DynFlags
     -> GenCCallPlatform
-    -> CmmCallTarget            -- function to call
-    -> [HintedCmmFormal]        -- where to put the result
-    -> [HintedCmmActual]        -- arguments (of mixed type)
+    -> ForeignTarget            -- function to call
+    -> [CmmFormal]        -- where to put the result
+    -> [CmmActual]        -- arguments (of mixed type)
     -> NatM InstrBlock
 
 {-
@@ -897,13 +906,13 @@ genCCall'
 -}
 
 
-genCCall' _ _ (CmmPrim MO_WriteBarrier _) _ _
+genCCall' _ _ (PrimTarget MO_WriteBarrier) _ _
  = return $ unitOL LWSYNC
 
-genCCall' _ _ (CmmPrim _ (Just stmts)) _ _
-    = stmtsToInstrs stmts
+genCCall' _ _ (PrimTarget MO_Touch) _ _
+ = return $ nilOL
 
-genCCall' dflags gcp target dest_regs argsAndHints
+genCCall' dflags gcp target dest_regs args0
   = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps)
         -- we rely on argument promotion in the codeGen
     do
@@ -915,9 +924,9 @@ genCCall' dflags gcp target dest_regs argsAndHints
                                                         (toOL []) []
 
         (labelOrExpr, reduceToFF32) <- case target of
-            CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False)
-            CmmCallee expr _ -> return  (Right expr, False)
-            CmmPrim mop _ -> outOfLineMachOp mop
+            ForeignTarget (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False)
+            ForeignTarget expr _ -> return  (Right expr, False)
+            PrimTarget mop -> outOfLineMachOp mop
 
         let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode
             codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32
@@ -948,17 +957,16 @@ genCCall' dflags gcp target dest_regs argsAndHints
                                 GCPLinux -> roundTo 16 finalStack
 
         -- need to remove alignment information
-        argsAndHints' | CmmPrim mop _ <- target,
+        args | PrimTarget mop <- target,
                         (mop == MO_Memcpy ||
                          mop == MO_Memset ||
                          mop == MO_Memmove)
-                      = init argsAndHints
+                      = init args0
 
                       | otherwise
-                      = argsAndHints
+                      = args0
 
-        args = map hintlessCmm argsAndHints'
-        argReps = map (cmmExprType dflags) args
+        argReps = map (cmmExprType dflags) args0
 
         roundTo a x | x `mod` a == 0 = x
                     | otherwise = x + a - (x `mod` a)
@@ -1086,7 +1094,7 @@ genCCall' dflags gcp target dest_regs argsAndHints
         moveResult reduceToFF32 =
             case dest_regs of
                 [] -> nilOL
-                [CmmHinted dest _hint]
+                [dest]
                     | reduceToFF32 && isFloat32 rep   -> unitOL (FRSP r_dest f1)
                     | isFloat32 rep || isFloat64 rep -> unitOL (MR r_dest f1)
                     | isWord64 rep -> toOL [MR (getHiVRegFromLo r_dest) r3,
diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs
index 1f5e809abb..40827d4a6f 100644
--- a/compiler/nativeGen/PPC/Instr.hs
+++ b/compiler/nativeGen/PPC/Instr.hs
@@ -36,7 +36,7 @@ import Reg
 import CodeGen.Platform
 import BlockId
 import DynFlags
-import OldCmm
+import Cmm
 import FastString
 import CLabel
 import Outputable
diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs
index 045ce8d48e..cbeabdd8a9 100644
--- a/compiler/nativeGen/PPC/Ppr.hs
+++ b/compiler/nativeGen/PPC/Ppr.hs
@@ -30,7 +30,7 @@ import Reg
 import RegClass
 import TargetReg
 
-import OldCmm
+import Cmm hiding (topInfoTable)
 import BlockId
 
 import CLabel
diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs
index 2b74d1daea..0fd93e17d0 100644
--- a/compiler/nativeGen/PPC/RegInfo.hs
+++ b/compiler/nativeGen/PPC/RegInfo.hs
@@ -29,7 +29,7 @@ where
 import PPC.Instr
 
 import BlockId
-import OldCmm
+import Cmm
 import CLabel
 
 import Unique
diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs
index d4123aca84..f92351bd22 100644
--- a/compiler/nativeGen/PPC/Regs.hs
+++ b/compiler/nativeGen/PPC/Regs.hs
@@ -50,7 +50,7 @@ import Reg
 import RegClass
 import Size
 
-import OldCmm
+import Cmm
 import CLabel           ( CLabel )
 import Unique