Reduce the number of passes over the cmm in llvm BE

4 files changed, 71 insertions, 113 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index c4848c90b1..1b1fd96514 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -35,80 +35,54 @@ import System.IO
 llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
 llvmCodeGen dflags h us cmms
   = do
-      let cmm = concat $ map (\(Cmm top) -> top) cmms
-
       bufh <- newBufHandle h
 
       Prt.bufLeftRender bufh $ pprLlvmHeader
 
-      env <- cmmDataLlvmGens dflags bufh cmm
-      cmmProcLlvmGens dflags bufh us env cmm 1 []
+      env' <- cmmDataLlvmGens dflags bufh env cdata []
+      cmmProcLlvmGens dflags bufh us env' cmm 1 []
 
       bFlush bufh
 
       return  ()
+  where
+        cmm = concat $ map (\(Cmm top) -> top) cmms
+
+        (cdata,env) = foldr split ([],initLlvmEnv) cmm
+
+        split (CmmData _ d'   ) (d,e) = (d':d,e)
+        split (CmmProc i l _ _) (d,e) =
+            let lbl = strCLabel_llvm $ if not (null i)
+                   then entryLblToInfoLbl l
+                   else l
+                env' = funInsert lbl llvmFunTy e
+            in (d,env')
 
 
 -- -----------------------------------------------------------------------------
 -- | Do llvm code generation on all these cmms data sections.
 --
-cmmDataLlvmGens
-      :: DynFlags
-      -> BufHandle
-      -> [RawCmmTop]
-      -> IO ( LlvmEnv )
-
-cmmDataLlvmGens _ _ []
-  = return ( initLlvmEnv )
-
-cmmDataLlvmGens dflags h cmm =
-    let exData (CmmData s d) = [(s,d)]
-        exData  _            = []
-
-        exProclbl (CmmProc i l _ _)
-                | not (null i) = [strCLabel_llvm $ entryLblToInfoLbl l]
-        exProclbl (CmmProc _ l _ _) | otherwise = [strCLabel_llvm l]
-        exProclbl _                             = []
-
-        cproc = concat $ map exProclbl cmm
-        cdata = concat $ map exData cmm
-        env = foldl (\e l -> funInsert l llvmFunTy e) initLlvmEnv cproc
-    in cmmDataLlvmGens' dflags h env cdata []
-
-cmmDataLlvmGens'
-      :: DynFlags
-      -> BufHandle
-      -> LlvmEnv
-      -> [(Section, [CmmStatic])]
-      -> [LlvmUnresData]
-      -> IO ( LlvmEnv )
-
-cmmDataLlvmGens' dflags h env [] lmdata
-    = do
-        let (env', lmdata') = resolveLlvmDatas dflags env lmdata []
-        let lmdoc = Prt.vcat $ map (pprLlvmData dflags) lmdata'
+cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [[CmmStatic]]
+                -> [LlvmUnresData] -> IO ( LlvmEnv )
 
+cmmDataLlvmGens dflags h env [] lmdata
+  = let (env', lmdata') = resolveLlvmDatas env lmdata []
+        lmdoc = Prt.vcat $ map pprLlvmData lmdata'
+    in do
         dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
-
         Prt.bufLeftRender h lmdoc
         return env'
 
-cmmDataLlvmGens' dflags h env (cmm:cmms) lmdata
-    = do
-        let lmdata'@(l, ty, _) = genLlvmData dflags cmm
-        let env' = funInsert (strCLabel_llvm l) ty env
-        cmmDataLlvmGens' dflags h env' cmms (lmdata ++ [lmdata'])
+cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
+  = let lmdata'@(l, ty, _) = genLlvmData cmm
+        env' = funInsert (strCLabel_llvm l) ty env
+    in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
 
 
 -- -----------------------------------------------------------------------------
 -- | Do llvm code generation on all these cmms procs.
 --
-cmmProcLlvmGens
-      :: DynFlags
-      -> BufHandle
-      -> UniqSupply
-      -> LlvmEnv
-      -> [RawCmmTop]
+cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop]
       -> Int          -- ^ count, used for generating unique subsections
       -> [LlvmVar]    -- ^ info tables that need to be marked as 'used'
       -> IO ()
@@ -116,34 +90,28 @@ cmmProcLlvmGens
 cmmProcLlvmGens _ _ _ _ [] _ []
   = return ()
 
-cmmProcLlvmGens dflags h _ _ [] _ ivars
-  = do
-      let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
-      let ty = (LMArray (length ivars) i8Ptr)
-      let usedArray = LMStaticArray (map cast ivars) ty
-      let lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
-                      (Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
-      Prt.bufLeftRender h $ pprLlvmData dflags ([lmUsed], [])
+cmmProcLlvmGens _ h _ _ [] _ ivars
+  = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
+        ty     = (LMArray (length ivars) i8Ptr)
+        usedArray = LMStaticArray (map cast ivars) ty
+        lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
+                  (Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
+    in do
+        Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
 
 cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
   = do
-      (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
+    (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm
 
-      let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop dflags env' count) llvm
-      Prt.bufLeftRender h $ Prt.vcat docs
+    let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm
+    Prt.bufLeftRender h $ Prt.vcat docs
 
-      cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
+    cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars)
 
 
 -- | Complete llvm code generation phase for a single top-level chunk of Cmm.
-cmmLlvmGen
-      :: DynFlags
-      -> UniqSupply
-      -> LlvmEnv
-      -> RawCmmTop              -- ^ the cmm to generate code for
-      -> IO ( UniqSupply,
-              LlvmEnv,
-              [LlvmCmmTop] )   -- llvm code
+cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop
+            -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] )
 
 cmmLlvmGen dflags us env cmm
   = do
@@ -154,10 +122,10 @@ cmmLlvmGen dflags us env cmm
         (pprCmm $ Cmm [fixed_cmm])
 
     -- generate llvm code from cmm
-    let ((env', llvmBC), usGen) = initUs us $ genLlvmCode dflags env fixed_cmm
+    let ((env', llvmBC), usGen) = initUs us $ genLlvmCode env fixed_cmm
 
     dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code"
-        (vcat $ map (docToSDoc . fst . pprLlvmCmmTop dflags env' 0) llvmBC)
+        (vcat $ map (docToSDoc . fst . pprLlvmCmmTop env' 0) llvmBC)
 
     return (usGen, env', llvmBC)
 
@@ -165,18 +133,9 @@ cmmLlvmGen dflags us env cmm
 -- -----------------------------------------------------------------------------
 -- | Instruction selection
 --
-genLlvmCode
-    :: DynFlags
-    -> LlvmEnv
-    -> RawCmmTop
-    -> UniqSM (LlvmEnv, [LlvmCmmTop])
-
-genLlvmCode _ env (CmmData _ _)
-    = return (env, [])
-
-genLlvmCode _ env (CmmProc _ _ _ (ListGraph []))
-    = return (env, [])
-
-genLlvmCode _ env cp@(CmmProc _ _ _ _)
-    = genLlvmProc env cp
+genLlvmCode :: LlvmEnv -> RawCmmTop
+            -> UniqSM (LlvmEnv, [LlvmCmmTop])
+genLlvmCode env (CmmData _ _                 ) = return (env, [])
+genLlvmCode env (CmmProc _ _ _ (ListGraph [])) = return (env, [])
+genLlvmCode env cp@(CmmProc _ _ _ _          ) = genLlvmProc env cp
 
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index f5c71ab2b9..13fe123f48 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -275,7 +275,7 @@ genCall env target res args ret = do
             CmmPrim mop -> do
                 let name = cmmPrimOpFunctions mop
                 let lbl  = mkForeignLabel name Nothing
-                                            ForeignLabelInExternalPackage IsFunction
+                                    ForeignLabelInExternalPackage IsFunction
                 getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv
 
     (env2, fptr, stmts2, top2) <- getFunPtr target
@@ -335,7 +335,8 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
                            ++ show a ++ ")"
 
        (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr
-       arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top')
+       arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1,
+                               tops ++ top')
 
 arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
   = do (env', v1, stmts', top') <- exprToVar env e
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index e3d2adc079..13da03b840 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -15,7 +15,6 @@ import BlockId
 import CLabel
 import Cmm
 
-import DynFlags
 import FastString
 import qualified Outputable
 
@@ -38,8 +37,8 @@ structStr = fsLit "_struct"
 -- complete this completely though as we need to pass all CmmStatic
 -- sections before all references can be resolved. This last step is
 -- done by 'resolveLlvmData'.
-genLlvmData :: DynFlags -> (Section, [CmmStatic]) -> LlvmUnresData
-genLlvmData _ ( _ , (CmmDataLabel lbl):xs) =
+genLlvmData :: [CmmStatic] -> LlvmUnresData
+genLlvmData (CmmDataLabel lbl:xs) =
     let static  = map genData xs
         label   = strCLabel_llvm lbl
 
@@ -51,20 +50,20 @@ genLlvmData _ ( _ , (CmmDataLabel lbl):xs) =
         alias   = LMAlias (label `appendFS` structStr) strucTy
     in (lbl, alias, static)
 
-genLlvmData _ _ = panic "genLlvmData: CmmData section doesn't start with label!"
+genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!"
 
-resolveLlvmDatas :: DynFlags -> LlvmEnv -> [LlvmUnresData] -> [LlvmData]
+resolveLlvmDatas ::  LlvmEnv -> [LlvmUnresData] -> [LlvmData]
                  -> (LlvmEnv, [LlvmData])
-resolveLlvmDatas _ env [] ldata
+resolveLlvmDatas env [] ldata
   = (env, ldata)
 
-resolveLlvmDatas dflags env (udata : rest) ldata
-  = let (env', ndata) = resolveLlvmData dflags env udata
-    in resolveLlvmDatas dflags env' rest (ldata ++ [ndata])
+resolveLlvmDatas env (udata : rest) ldata
+  = let (env', ndata) = resolveLlvmData env udata
+    in resolveLlvmDatas env' rest (ldata ++ [ndata])
 
 -- | Fix up CLabel references now that we should have passed all CmmData.
-resolveLlvmData :: DynFlags -> LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
-resolveLlvmData _ env (lbl, alias, unres) =
+resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
+resolveLlvmData env (lbl, alias, unres) =
     let (env', static, refs) = resDatas env unres ([], [])
         refs'          = catMaybes refs
         struct         = Just $ LMStaticStruc static alias
diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
index 689be6c66c..5afbd174ce 100644
--- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs
@@ -15,7 +15,6 @@ import LlvmCodeGen.Data
 import CLabel
 import Cmm
 
-import DynFlags
 import FastString
 import Pretty
 import Unique
@@ -61,14 +60,14 @@ pprLlvmHeader = moduleLayout
 
 
 -- | Pretty print LLVM code
-pprLlvmCmmTop :: DynFlags -> LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
-pprLlvmCmmTop dflags _ _ (CmmData _ lmdata)
-  = (vcat $ map (pprLlvmData dflags) lmdata, [])
+pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
+pprLlvmCmmTop _ _ (CmmData _ lmdata)
+  = (vcat $ map pprLlvmData lmdata, [])
 
-pprLlvmCmmTop dflags env count (CmmProc info lbl _ (ListGraph blks))
+pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
   = let static = CmmDataLabel lbl : info
         (idoc, ivar) = if not (null info)
-                          then pprCmmStatic dflags env count static
+                          then pprCmmStatic env count static
                           else (empty, [])
     in (idoc $+$ (
         let sec = mkLayoutSection (count + 1)
@@ -87,18 +86,18 @@ pprLlvmCmmTop dflags env count (CmmProc info lbl _ (ListGraph blks))
 
 
 -- | Pretty print LLVM data code
-pprLlvmData :: DynFlags -> LlvmData -> Doc
-pprLlvmData _ (globals, types) =
+pprLlvmData :: LlvmData -> Doc
+pprLlvmData (globals, types) =
     let globals' = ppLlvmGlobals globals
         types'   = ppLlvmTypes types
     in types' $+$ globals'
 
 
 -- | Pretty print CmmStatic
-pprCmmStatic :: DynFlags -> LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
-pprCmmStatic dflags env count stat
-  = let unres = genLlvmData dflags (Data,stat)
-        (_, (ldata, ltypes)) = resolveLlvmData dflags env unres
+pprCmmStatic :: LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
+pprCmmStatic env count stat
+  = let unres = genLlvmData stat
+        (_, (ldata, ltypes)) = resolveLlvmData env unres
 
         setSection (gv@(LMGlobalVar s ty l _ _), d)
             = let v = if l == Internal then [gv] else []
@@ -107,7 +106,7 @@ pprCmmStatic dflags env count stat
         setSection v = (v,[])
 
         (ldata', llvmUsed) = mapAndUnzip setSection ldata
-    in (pprLlvmData dflags (ldata', ltypes), concat llvmUsed)
+    in (pprLlvmData (ldata', ltypes), concat llvmUsed)
 
 
 -- | Create an appropriate section declaration for subsection <n> of text