Commit 7626b2b9 authored by dterei's avatar dterei
Browse files

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.
parent f14953e7
......@@ -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
......
......@@ -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.
......
......@@ -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
--
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment