Fix ugly complexity issue in LLVM backend (#5652)

Compile time still isn't as good as I'd like but no easy changes
available. LLVM backend could do with a big rewrite to improve
performance as there are some ugly designs in it.

At least the test case isn't 10min anymore, just a few seconds now.

3 files changed, 39 insertions, 42 deletions

diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs
index 321fac37a8..f802fc414c 100644
--- a/compiler/llvmGen/LlvmCodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen.hs
@@ -36,7 +36,8 @@ import System.IO
 llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO ()
 llvmCodeGen dflags h us cmms
   = let cmm = concat cmms
-        (cdata,env) = foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
+        (cdata,env) = {-# SCC "llvm_split" #-}
+                      foldr split ([],initLlvmEnv (targetPlatform dflags)) cmm
         split (CmmData s d' ) (d,e) = ((s,d'):d,e)
         split (CmmProc i l _) (d,e) =
             let lbl = strCLabel_llvm env $ case i of
@@ -51,7 +52,7 @@ llvmCodeGen dflags h us cmms
         ver  <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags
         env' <- {-# SCC "llvm_datas_gen" #-}
                 cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata []
-        _ <- {-# SCC "llvm_procs_gen" #-}
+        {-# SCC "llvm_procs_gen" #-}
              cmmProcLlvmGens dflags bufh us env' cmm 1 []
         bFlush bufh
         return  ()
@@ -65,19 +66,23 @@ cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)]
 
 cmmDataLlvmGens dflags h env [] lmdata
   = let (env', lmdata') = {-# SCC "llvm_resolve" #-}
-                          resolveLlvmDatas env lmdata []
+                          resolveLlvmDatas env lmdata
         lmdoc = {-# SCC "llvm_data_ppr" #-}
                 Prt.vcat $ map pprLlvmData lmdata'
     in do
         dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
-        Prt.bufLeftRender h lmdoc
+        {-# SCC "llvm_data_out" #-}
+            Prt.bufLeftRender h lmdoc
         return env'
 
 cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
-  = let lmdata'@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
-                                genLlvmData env cmm
-        env' = funInsert (strCLabel_llvm env l) ty env
-    in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
+  = let lm@(l, _, ty, _) = {-# SCC "llvm_data_gen" #-}
+                           genLlvmData env cmm
+        env' = {-# SCC "llvm_data_insert" #-}
+               funInsert (strCLabel_llvm env l) ty env
+        lmdata' = {-# SCC "llvm_data_append" #-}
+                  lm:lmdata
+    in cmmDataLlvmGens dflags h env' cmms lmdata'
 
 
 -- -----------------------------------------------------------------------------
@@ -98,7 +103,7 @@ cmmProcLlvmGens _ h _ _ [] _ ivars
         usedArray = LMStaticArray (map cast ivars') ty
         lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
                   (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray)
-    in Prt.bufLeftRender h $ {-# SCC "llvm_data_ppr" #-}
+    in Prt.bufLeftRender h $ {-# SCC "llvm_used_ppr" #-}
                              pprLlvmData ([lmUsed], [])
 
 cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars
diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
index 1ea5d0c038..5b9e711b15 100644
--- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
+++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs
@@ -57,8 +57,7 @@ basicBlocksCodeGen env ([]) (blocks, tops)
   = do let (blocks', allocs) = mapAndUnzip dominateAllocs blocks
        let allocs' = concat allocs
        let ((BasicBlock id fstmts):rblks) = blocks'
-       fplog <- funPrologue
-       let fblocks = (BasicBlock id (fplog ++  allocs' ++ fstmts)):rblks
+       let fblocks = (BasicBlock id $ funPrologue ++  allocs' ++ fstmts):rblks
        return (env, fblocks, tops)
 
 basicBlocksCodeGen env (block:blocks) (lblocks', ltops')
@@ -1189,13 +1188,13 @@ genLit _ CmmHighStackMark
 --
 
 -- | Function prologue. Load STG arguments into variables for function.
-funPrologue :: UniqSM [LlvmStatement]
-funPrologue = liftM concat $ mapM getReg activeStgRegs
+funPrologue :: [LlvmStatement]
+funPrologue = concat $ map getReg activeStgRegs
     where getReg rr =
-            let reg = lmGlobalRegVar rr
-                arg = lmGlobalRegArg rr
+            let reg   = lmGlobalRegVar rr
+                arg   = lmGlobalRegArg rr
                 alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1
-            in return [alloc, Store arg reg]
+            in [alloc, Store arg reg]
 
 
 -- | Function epilogue. Load STG variables to use as argument for call.
diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs
index c773e1c009..8e42149dce 100644
--- a/compiler/llvmGen/LlvmCodeGen/Data.hs
+++ b/compiler/llvmGen/LlvmCodeGen/Data.hs
@@ -18,8 +18,7 @@ import OldCmm
 import FastString
 import qualified Outputable
 
-import Data.Maybe
-
+import Data.List (foldl')
 
 -- ----------------------------------------------------------------------------
 -- * Constants
@@ -51,37 +50,33 @@ genLlvmData env (sec, Statics lbl xs) =
     in (lbl, sec, alias, static)
 
 
-resolveLlvmDatas ::  LlvmEnv -> [LlvmUnresData] -> [LlvmData]
-                 -> (LlvmEnv, [LlvmData])
-resolveLlvmDatas env [] ldata
-  = (env, ldata)
-
-resolveLlvmDatas env (udata : rest) ldata
-  = let (env', ndata) = resolveLlvmData env udata
-    in resolveLlvmDatas env' rest (ldata ++ [ndata])
+resolveLlvmDatas ::  LlvmEnv -> [LlvmUnresData] -> (LlvmEnv, [LlvmData])
+resolveLlvmDatas env ldata
+  = foldl' res (env, []) ldata
+  where res (e, xs) ll =
+            let (e', nd) = resolveLlvmData e ll
+            in (e', nd:xs)
 
 -- | Fix up CLabel references now that we should have passed all CmmData.
 resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
 resolveLlvmData env (lbl, sec, alias, unres) =
     let (env', static, refs) = resDatas env unres ([], [])
-        refs'          = catMaybes refs
         struct         = Just $ LMStaticStruc static alias
         label          = strCLabel_llvm env lbl
         link           = if (externallyVisibleCLabel lbl)
                             then ExternallyVisible else Internal
         const          = isSecConstant sec
         glob           = LMGlobalVar label alias link Nothing Nothing const
-    in (env', (refs' ++ [(glob, struct)], [alias]))
-
+    in (env', ((glob,struct):refs, [alias]))
 
 -- | Should a data in this section be considered constant
 isSecConstant :: Section -> Bool
 isSecConstant Text                    = True
-isSecConstant Data                    = False
 isSecConstant ReadOnlyData            = True
 isSecConstant RelocatableReadOnlyData = True
-isSecConstant UninitialisedData       = False
 isSecConstant ReadOnlyData16          = True
+isSecConstant Data                    = False
+isSecConstant UninitialisedData       = False
 isSecConstant (OtherSection _)        = False
 
 
@@ -90,13 +85,13 @@ isSecConstant (OtherSection _)        = False
 --
 
 -- | Resolve data list
-resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [Maybe LMGlobal])
-         -> (LlvmEnv, [LlvmStatic], [Maybe LMGlobal])
+resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal])
+         -> (LlvmEnv, [LlvmStatic], [LMGlobal])
 
-resDatas env [] (stat, glob)
-  = (env, stat, glob)
+resDatas env [] (stats, glob)
+  = (env, stats, glob)
 
-resDatas env (cmm : rest) (stats, globs)
+resDatas env (cmm:rest) (stats, globs)
   = let (env', nstat, nglob) = resData env cmm
     in resDatas env' rest (stats ++ [nstat], globs ++ nglob)
 
@@ -106,9 +101,9 @@ resDatas env (cmm : rest) (stats, globs)
 -- module. If it has we can retrieve its type and make a pointer, otherwise
 -- we introduce a generic external definition for the referenced label and
 -- then make a pointer.
-resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal])
+resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [LMGlobal])
 
-resData env (Right stat) = (env, stat, [Nothing])
+resData env (Right stat) = (env, stat, [])
 
 resData env (Left cmm@(CmmLabel l)) =
     let label = strCLabel_llvm env l
@@ -120,14 +115,14 @@ resData env (Left cmm@(CmmLabel l)) =
                 let glob@(var, _) = genStringLabelRef label
                     env' =  funInsert label (pLower $ getVarType var) env
                     ptr  = LMStaticPointer var
-                in  (env', LMPtoI ptr lmty, [Just glob])
+                in  (env', LMPtoI ptr lmty, [glob])
             -- Referenced data exists in this module, retrieve type and make
             -- pointer to it.
             Just ty' ->
                 let var = LMGlobalVar label (LMPointer ty')
                             ExternallyVisible Nothing Nothing False
                     ptr  = LMStaticPointer var
-                in (env, LMPtoI ptr lmty, [Nothing])
+                in (env, LMPtoI ptr lmty, [])
 
 resData env (Left (CmmLabelOff label off)) =
     let (env', var, glob) = resData env (Left (CmmLabel label))
@@ -161,7 +156,6 @@ genData (CmmUninitialised bytes)
 genData (CmmStaticLit lit)
     = genStaticLit lit
 
-
 -- | Generate Llvm code for a static literal.
 --
 -- Will either generate the code or leave it unresolved if it is a 'CLabel'
@@ -183,7 +177,6 @@ genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
 genStaticLit (CmmHighStackMark)
     = panic "genStaticLit: CmmHighStackMark unsupported!"
 
-
 -- -----------------------------------------------------------------------------
 -- * Misc
 --