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.

1 files changed, 28 insertions, 59 deletions

diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 67d8fd8817..bdb7f69b11 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -6,12 +6,15 @@
 --
 -----------------------------------------------------------------------------
 
+{-# LANGUAGE GADTs #-}
 module CgUtils ( fixStgRegisters ) where
 
 #include "HsVersions.h"
 
 import CodeGen.Platform
-import OldCmm
+import Cmm
+import Hoopl
+import CmmUtils
 import CLabel
 import DynFlags
 import Outputable
@@ -96,59 +99,28 @@ get_Regtable_addr_from_offset dflags _ offset =
 fixStgRegisters :: DynFlags -> RawCmmDecl -> RawCmmDecl
 fixStgRegisters _ top@(CmmData _ _) = top
 
-fixStgRegisters dflags (CmmProc info lbl live (ListGraph blocks)) =
-  let blocks' = map (fixStgRegBlock dflags) blocks
-  in CmmProc info lbl live $ ListGraph blocks'
+fixStgRegisters dflags (CmmProc info lbl live graph) =
+  let graph' = modifyGraph (mapGraphBlocks (fixStgRegBlock dflags)) graph
+  in CmmProc info lbl live graph'
 
-fixStgRegBlock :: DynFlags -> CmmBasicBlock -> CmmBasicBlock
-fixStgRegBlock dflags (BasicBlock id stmts) =
-  let stmts' = map (fixStgRegStmt dflags) stmts
-  in BasicBlock id stmts'
+fixStgRegBlock :: DynFlags -> Block CmmNode e x -> Block CmmNode e x
+fixStgRegBlock dflags block = mapBlock (fixStgRegStmt dflags) block
 
-fixStgRegStmt :: DynFlags -> CmmStmt -> CmmStmt
-fixStgRegStmt dflags stmt
-  = case stmt of
-        CmmAssign (CmmGlobal reg) src ->
-            let src' = fixStgRegExpr dflags src
-                baseAddr = get_GlobalReg_addr dflags reg
-            in case reg `elem` activeStgRegs platform of
-                True  -> CmmAssign (CmmGlobal reg) src'
-                False -> CmmStore baseAddr src'
-
-        CmmAssign reg src ->
-            let src' = fixStgRegExpr dflags src
-            in CmmAssign reg src'
-
-        CmmStore addr src -> CmmStore (fixStgRegExpr dflags addr) (fixStgRegExpr dflags src)
-
-        CmmCall target regs args returns ->
-            let target' = case target of
-                    CmmCallee e conv -> CmmCallee (fixStgRegExpr dflags e) conv
-                    CmmPrim op mStmts ->
-                        CmmPrim op (fmap (map (fixStgRegStmt dflags)) mStmts)
-                args' = map (\(CmmHinted arg hint) ->
-                                (CmmHinted (fixStgRegExpr dflags arg) hint)) args
-            in CmmCall target' regs args' returns
-
-        CmmCondBranch test dest -> CmmCondBranch (fixStgRegExpr dflags test) dest
-
-        CmmSwitch expr ids -> CmmSwitch (fixStgRegExpr dflags expr) ids
+fixStgRegStmt :: DynFlags -> CmmNode e x -> CmmNode e x
+fixStgRegStmt dflags stmt = fixAssign $ mapExpDeep fixExpr stmt
+  where
+    platform = targetPlatform dflags
 
-        CmmJump addr live -> CmmJump (fixStgRegExpr dflags addr) live
-
-        -- CmmNop, CmmComment, CmmBranch, CmmReturn
-        _other -> stmt
-    where platform = targetPlatform dflags
-
-
-fixStgRegExpr :: DynFlags -> CmmExpr -> CmmExpr
-fixStgRegExpr dflags expr
-  = case expr of
-        CmmLoad addr ty -> CmmLoad (fixStgRegExpr dflags addr) ty
-
-        CmmMachOp mop args -> CmmMachOp mop args'
-            where args' = map (fixStgRegExpr dflags) args
+    fixAssign stmt =
+      case stmt of
+        CmmAssign (CmmGlobal reg) src ->
+            let baseAddr = get_GlobalReg_addr dflags reg
+            in case reg `elem` activeStgRegs (targetPlatform dflags) of
+                True  -> CmmAssign (CmmGlobal reg) src
+                False -> CmmStore baseAddr src
+        other_stmt -> other_stmt
 
+    fixExpr expr = case expr of
         CmmReg (CmmGlobal reg) ->
             -- Replace register leaves with appropriate StixTrees for
             -- the given target.  MagicIds which map to a reg on this
@@ -161,9 +133,8 @@ fixStgRegExpr dflags expr
                 False ->
                     let baseAddr = get_GlobalReg_addr dflags reg
                     in case reg of
-                        BaseReg -> fixStgRegExpr dflags baseAddr
-                        _other  -> fixStgRegExpr dflags
-                                    (CmmLoad baseAddr (globalRegType dflags reg))
+                        BaseReg -> baseAddr
+                        _other  -> CmmLoad baseAddr (globalRegType dflags reg)
 
         CmmRegOff (CmmGlobal reg) offset ->
             -- RegOf leaves are just a shorthand form. If the reg maps
@@ -171,12 +142,10 @@ fixStgRegExpr dflags expr
             -- expand it and defer to the above code.
             case reg `elem` activeStgRegs platform of
                 True  -> expr
-                False -> fixStgRegExpr dflags (CmmMachOp (MO_Add (wordWidth dflags)) [
-                                    CmmReg (CmmGlobal reg),
+                False -> CmmMachOp (MO_Add (wordWidth dflags)) [
+                                    fixExpr (CmmReg (CmmGlobal reg)),
                                     CmmLit (CmmInt (fromIntegral offset)
-                                                (wordWidth dflags))])
+                                                   (wordWidth dflags))]
 
-        -- CmmLit, CmmReg (CmmLocal), CmmStackSlot
-        _other -> expr
-    where platform = targetPlatform dflags
+        other_expr -> other_expr