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, 102 insertions, 95 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index d62fbf4397..b5d4b4a76c 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -3,6 +3,7 @@
 -- | Handle conversion of CmmProc to LLVM code.
 --
 
+{-# LANGUAGE GADTs #-}
 module LlvmCodeGen.CodeGen ( genLlvmProc ) where
 
 #include "HsVersions.h"
@@ -14,8 +15,10 @@ import LlvmCodeGen.Regs
 import BlockId
 import CodeGen.Platform ( activeStgRegs, callerSaves )
 import CLabel
-import OldCmm
-import qualified OldPprCmm as PprCmm
+import Cmm
+import PprCmm
+import CmmUtils
+import Hoopl
 
 import DynFlags
 import FastString
@@ -37,9 +40,10 @@ type LlvmStatements = OrdList LlvmStatement
 -- | Top-level of the LLVM proc Code generator
 --
 genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl])
-genLlvmProc env proc0@(CmmProc _ lbl live (ListGraph blocks)) = do
+genLlvmProc env proc0@(CmmProc infos lbl live graph) = do
+    let blocks = toBlockList graph
     (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], [])
-    let info = topInfoTable proc0
+    let info = mapLookup (g_entry graph) infos
         proc = CmmProc info lbl live (ListGraph lmblocks)
     return (env', proc:lmdata)
 
@@ -52,22 +56,23 @@ genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!"
 -- | Generate code for a list of blocks that make up a complete procedure.
 basicBlocksCodeGen :: LlvmEnv
                    -> LiveGlobalRegs
-                   -> [CmmBasicBlock]
+                   -> [CmmBlock]
                    -> ( [LlvmBasicBlock] , [LlvmCmmDecl] )
                    -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] )
-basicBlocksCodeGen env live ([]) (blocks, tops)
-  = do let dflags = getDflags env
-       let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
-       let allocs' = concat allocs
-       let ((BasicBlock id fstmts):rblks) = blocks'
-       let fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
-       return (env, fblocks, tops)
-
-basicBlocksCodeGen env live (block:blocks) (lblocks', ltops')
+basicBlocksCodeGen env live [] (blocks0, tops0)
+  = return (env, fblocks, tops)
+  where
+     dflags   = getDflags env
+     blocks   = reverse blocks0
+     tops     = reverse tops0
+     (blocks', allocs) = mapAndUnzip dominateAllocs blocks
+     allocs'  = concat allocs
+     (BasicBlock id fstmts : rblks) = blocks'
+     fblocks  = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks
+
+basicBlocksCodeGen env live (block:blocks) (lblocks, ltops)
   = do (env', lb, lt) <- basicBlockCodeGen env block
-       let lblocks = lblocks' ++ lb
-       let ltops   = ltops' ++ lt
-       basicBlocksCodeGen env' live blocks (lblocks, ltops)
+       basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops)
 
 
 -- | Allocations need to be extracted so they can be moved to the entry
@@ -81,16 +86,19 @@ dominateAllocs (BasicBlock id stmts)
 
 
 -- | Generate code for one block
-basicBlockCodeGen ::  LlvmEnv
-                  -> CmmBasicBlock
-                  -> UniqSM ( LlvmEnv, [LlvmBasicBlock], [LlvmCmmDecl] )
-basicBlockCodeGen env (BasicBlock id stmts)
-  = do (env', instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
-       return (env', [BasicBlock id (fromOL instrs)], top)
-
+basicBlockCodeGen :: LlvmEnv
+                  -> CmmBlock
+                  -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] )
+basicBlockCodeGen env block
+  = do let (CmmEntry id, nodes, tail)  = blockSplit block
+       let stmts = blockToList nodes
+       (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, [])
+       (env'', tail_instrs, top')  <- stmtToInstrs env' tail
+       let instrs = fromOL (mid_instrs `appOL` tail_instrs)
+       return (env'', BasicBlock id instrs, top' ++ top)
 
 -- -----------------------------------------------------------------------------
--- * CmmStmt code generation
+-- * CmmNode code generation
 --
 
 -- A statement conversion return data.
@@ -100,8 +108,8 @@ basicBlockCodeGen env (BasicBlock id stmts)
 type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl])
 
 
--- | Convert a list of CmmStmt's to LlvmStatement's
-stmtsToInstrs :: LlvmEnv -> [CmmStmt] -> (LlvmStatements, [LlvmCmmDecl])
+-- | Convert a list of CmmNode's to LlvmStatement's
+stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl])
               -> UniqSM StmtData
 stmtsToInstrs env [] (llvm, top)
   = return (env, llvm, top)
@@ -111,34 +119,28 @@ stmtsToInstrs env (stmt : stmts) (llvm, top)
         stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops)
 
 
--- | Convert a CmmStmt to a list of LlvmStatement's
-stmtToInstrs :: LlvmEnv -> CmmStmt
+-- | Convert a CmmNode to a list of LlvmStatement's
+stmtToInstrs :: LlvmEnv -> CmmNode e x
              -> UniqSM StmtData
 stmtToInstrs env stmt = case stmt of
 
-    CmmNop               -> return (env, nilOL, [])
     CmmComment _         -> return (env, nilOL, []) -- nuke comments
 
     CmmAssign reg src    -> genAssign env reg src
     CmmStore addr src    -> genStore env addr src
 
     CmmBranch id         -> genBranch env id
-    CmmCondBranch arg id -> genCondBranch env arg id
+    CmmCondBranch arg true false -> genCondBranch env arg true false
     CmmSwitch arg ids    -> genSwitch env arg ids
 
     -- Foreign Call
-    CmmCall target res args ret
-        -> genCall env target res args ret
+    CmmUnsafeForeignCall target res args -> genCall env target res args
 
     -- Tail call
-    CmmJump arg live     -> genJump env arg live
-
-    -- CPS, only tail calls, no return's
-    -- Actually, there are a few return statements that occur because of hand
-    -- written Cmm code.
-    CmmReturn
-        -> return (env, unitOL $ Return Nothing, [])
+    CmmCall { cml_target = arg,
+              cml_args_regs = live } -> genJump env arg live
 
+    _ -> panic "Llvm.CodeGen.stmtToInstrs"
 
 -- | Memory barrier instruction for LLVM >= 3.0
 barrier :: LlvmEnv -> UniqSM StmtData
@@ -171,12 +173,12 @@ oldBarrier env = do
         lmTrue  = mkIntLit i1 (-1)
 
 -- | Foreign Calls
-genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual]
-              -> CmmReturnInfo -> UniqSM StmtData
+genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual]
+              -> UniqSM StmtData
 
 -- Write barrier needs to be handled specially as it is implemented as an LLVM
 -- intrinsic function.
-genCall env (CmmPrim MO_WriteBarrier _) _ _ _
+genCall env (PrimTarget MO_WriteBarrier) _ _
  | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC]
     = return (env, nilOL, [])
  | getLlvmVer env > 29 = barrier env
@@ -186,7 +188,7 @@ genCall env (CmmPrim MO_WriteBarrier _) _ _ _
 -- types and things like Word8 are backed by an i32 and just present a logical
 -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM
 -- is strict about types.
-genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
+genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do
     let dflags = getDflags env
         width = widthToLlvmInt w
         dstTy = cmmToLlvmType $ localRegType dst
@@ -194,7 +196,9 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
                           CC_Ccc width FixedArgs (tysToParams [width]) Nothing
         (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst)
 
-    (env2, argsV, stmts2, top2) <- arg_vars env1 args ([], nilOL, [])
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, [])
     (env3, fptr, stmts3, top3)  <- getFunPtr env2 funTy t
     (argsV', stmts4)            <- castVars dflags $ zip argsV [width]
     (retV, s1)                  <- doExpr width $ Call StdCall fptr argsV' []
@@ -207,7 +211,7 @@ genCall env t@(CmmPrim (MO_PopCnt w) _) [CmmHinted dst _] args _ = do
 
 -- Handle memcpy function specifically since llvm's intrinsic version takes
 -- some extra parameters.
-genCall env t@(CmmPrim op _) [] args' CmmMayReturn
+genCall env t@(PrimTarget op) [] args'
  | op == MO_Memcpy ||
    op == MO_Memset ||
    op == MO_Memmove = do
@@ -220,7 +224,9 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
         funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                              CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing
 
-    (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+    let (_, arg_hints) = foreignTargetHints t
+    let args_hints = zip args arg_hints
+    (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy t
     (argVars', stmts3)            <- castVars dflags $ zip argVars argTy
 
@@ -236,48 +242,43 @@ genCall env t@(CmmPrim op _) [] args' CmmMayReturn
     -- Fix for trac #6158. Since LLVM 3.1, opt fails when given anything other
     -- than a direct constant (i.e. 'i32 8') as the alignment argument for the
     -- memcpy & co llvm intrinsic functions. So we handle this directly now.
-    extractLit (CmmHinted (CmmLit (CmmInt i _)) _) = mkIntLit i32 i
+    extractLit (CmmLit (CmmInt i _)) = mkIntLit i32 i
     extractLit _other = trace ("WARNING: Non constant alignment value given" ++ 
                                " for memcpy! Please report to GHC developers")
                         mkIntLit i32 0
 
-genCall env (CmmPrim _ (Just stmts)) _ _ _
-    = stmtsToInstrs env stmts (nilOL, [])
-
 -- Handle all other foreign calls and prim ops.
-genCall env target res args ret = do
+genCall env target res args = do
 
     let dflags = getDflags env
 
     -- parameter types
-    let arg_type (CmmHinted _ AddrHint) = i8Ptr
+    let arg_type (_, AddrHint) = i8Ptr
         -- cast pointers to i8*. Llvm equivalent of void*
-        arg_type (CmmHinted expr _    ) = cmmToLlvmType $ cmmExprType dflags expr
+        arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr
 
     -- ret type
-    let ret_type ([]) = LMVoid
-        ret_type ([CmmHinted _ AddrHint]) = i8Ptr
-        ret_type ([CmmHinted reg _])      = cmmToLlvmType $ localRegType reg
+    let ret_type [] = LMVoid
+        ret_type [(_, AddrHint)] = i8Ptr
+        ret_type [(reg, _)]      = cmmToLlvmType $ localRegType reg
         ret_type t = panic $ "genCall: Too many return values! Can only handle"
                         ++ " 0 or 1, given " ++ show (length t) ++ "."
 
-    -- extract Cmm call convention
-    let cconv = case target of
-            CmmCallee _ conv -> conv
-            CmmPrim   _ _    -> PrimCallConv
-
-    -- translate to LLVM call convention
-    let lmconv = case cconv of
-            StdCallConv  -> case platformArch (getLlvmPlatform env) of
-                            ArchX86    -> CC_X86_Stdcc
-                            ArchX86_64 -> CC_X86_Stdcc
-                            _          -> CC_Ccc
-            CCallConv    -> CC_Ccc
-            CApiConv     -> CC_Ccc
-            PrimCallConv -> CC_Ccc
+    -- extract Cmm call convention, and translate to LLVM call convention
+    let lmconv = case target of
+            ForeignTarget _ (ForeignConvention conv _ _ _) ->
+              case conv of
+                 StdCallConv  -> case platformArch (getLlvmPlatform env) of
+                                 ArchX86    -> CC_X86_Stdcc
+                                 ArchX86_64 -> CC_X86_Stdcc
+                                 _          -> CC_Ccc
+                 CCallConv    -> CC_Ccc
+                 CApiConv     -> CC_Ccc
+
+            PrimTarget   _ -> CC_Ccc
 
     {-
-        Some of the possibilities here are a worry with the use of a custom
+        CC_Ccc of the possibilities here are a worry with the use of a custom
         calling convention for passing STG args. In practice the more
         dangerous combinations (e.g StdCall + llvmGhcCC) don't occur.
 
@@ -285,23 +286,31 @@ genCall env target res args ret = do
     -}
 
     -- call attributes
-    let fnAttrs | ret == CmmNeverReturns = NoReturn : llvmStdFunAttrs
-                | otherwise              = llvmStdFunAttrs
+    let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs
+                | otherwise     = llvmStdFunAttrs
+
+        never_returns = case target of
+             ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True
+             _ -> False
 
     -- fun type
+    let (res_hints, arg_hints) = foreignTargetHints target
+    let args_hints = zip args arg_hints
+    let ress_hints = zip res  res_hints
     let ccTy  = StdCall -- tail calls should be done through CmmJump
-    let retTy = ret_type res
-    let argTy = tysToParams $ map arg_type args
+    let retTy = ret_type ress_hints
+    let argTy = tysToParams $ map arg_type args_hints
     let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible
                              lmconv retTy FixedArgs argTy (llvmFunAlign dflags)
 
 
-    (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, [])
+
+    (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, [])
     (env2, fptr, stmts2, top2)    <- getFunPtr env1 funTy target
 
-    let retStmt | ccTy == TailCall       = unitOL $ Return Nothing
-                | ret == CmmNeverReturns = unitOL $ Unreachable
-                | otherwise              = nilOL
+    let retStmt | ccTy == TailCall  = unitOL $ Return Nothing
+                | never_returns     = unitOL $ Unreachable
+                | otherwise         = nilOL
 
     let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env)
 
@@ -315,10 +324,10 @@ genCall env target res args ret = do
         _ -> do
             (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs
             -- get the return register
-            let ret_reg ([CmmHinted reg hint]) = (reg, hint)
+            let ret_reg [reg] = reg
                 ret_reg t = panic $ "genCall: Bad number of registers! Can only handle"
                                 ++ " 1, given " ++ show (length t) ++ "."
-            let (creg, _) = ret_reg res
+            let creg = ret_reg res
             let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg)
             let allStmts = stmts `snocOL` s1 `appOL` stmts3
             if retTy == pLower (getVarType vreg)
@@ -342,12 +351,12 @@ genCall env target res args ret = do
 
 
 -- | Create a function pointer from a target.
-getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget
+getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget
           -> UniqSM ExprData
 getFunPtr env funTy targ = case targ of
-    CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
+    ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl
 
-    CmmCallee expr _ -> do
+    ForeignTarget expr _ -> do
         (env', v1, stmts, top) <- exprToVar env expr
         let fty = funTy $ fsLit "dynamic"
             cast = case getVarType v1 of
@@ -360,7 +369,7 @@ getFunPtr env funTy targ = case targ of
         (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty)
         return (env', v2, stmts `snocOL` s1, top)
 
-    CmmPrim mop _ -> litCase $ cmmPrimOpFunctions env mop
+    PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop
 
     where
         litCase name = do
@@ -392,14 +401,14 @@ getFunPtr env funTy targ = case targ of
 
 -- | Conversion of call arguments.
 arg_vars :: LlvmEnv
-         -> [HintedCmmActual]
+         -> [(CmmActual, ForeignHint)]
          -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl])
          -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl])
 
 arg_vars env [] (vars, stmts, tops)
   = return (env, vars, stmts, tops)
 
-arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
+arg_vars env ((e, AddrHint):rest) (vars, stmts, tops)
   = do (env', v1, stmts', top') <- exprToVar env e
        let op = case getVarType v1 of
                ty | isPointer ty -> LM_Bitcast
@@ -412,7 +421,7 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
        arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
                                tops ++ top')
 
-arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
+arg_vars env ((e, _):rest) (vars, stmts, tops)
   = do (env', v1, stmts', top') <- exprToVar env e
        arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top')
 
@@ -673,17 +682,15 @@ genBranch env id =
 
 
 -- | Conditional branch
-genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> UniqSM StmtData
-genCondBranch env cond idT = do
-    idF <- getUniqueUs
+genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData
+genCondBranch env cond idT idF = do
     let labelT = blockIdToLlvm idT
-    let labelF = LMLocalVar idF LMLabel
+    let labelF = blockIdToLlvm idF
     (env', vc, stmts, top) <- exprToVarOpt env i1Option cond
     if getVarType vc == i1
         then do
             let s1 = BranchIf vc labelT labelF
-            let s2 = MkLabel idF
-            return $ (env', stmts `snocOL` s1 `snocOL` s2, top)
+            return $ (env', stmts `snocOL` s1, top)
         else
             panic $ "genCondBranch: Cond expr not bool! (" ++ show vc ++ ")"