Commit 09e6aba8 authored by dterei's avatar dterei

Reduce the number of passes over the cmm in llvm BE

parent 4bb4a1cf
...@@ -35,80 +35,54 @@ import System.IO ...@@ -35,80 +35,54 @@ import System.IO
llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO ()
llvmCodeGen dflags h us cmms llvmCodeGen dflags h us cmms
= do = do
let cmm = concat $ map (\(Cmm top) -> top) cmms
bufh <- newBufHandle h bufh <- newBufHandle h
Prt.bufLeftRender bufh $ pprLlvmHeader Prt.bufLeftRender bufh $ pprLlvmHeader
env <- cmmDataLlvmGens dflags bufh cmm env' <- cmmDataLlvmGens dflags bufh env cdata []
cmmProcLlvmGens dflags bufh us env cmm 1 [] cmmProcLlvmGens dflags bufh us env' cmm 1 []
bFlush bufh bFlush bufh
return () 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. -- | Do llvm code generation on all these cmms data sections.
-- --
cmmDataLlvmGens cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [[CmmStatic]]
:: DynFlags -> [LlvmUnresData] -> IO ( LlvmEnv )
-> 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 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 dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" $ docToSDoc lmdoc
Prt.bufLeftRender h lmdoc Prt.bufLeftRender h lmdoc
return env' return env'
cmmDataLlvmGens' dflags h env (cmm:cmms) lmdata cmmDataLlvmGens dflags h env (cmm:cmms) lmdata
= do = let lmdata'@(l, ty, _) = genLlvmData cmm
let lmdata'@(l, ty, _) = genLlvmData dflags cmm env' = funInsert (strCLabel_llvm l) ty env
let env' = funInsert (strCLabel_llvm l) ty env in cmmDataLlvmGens dflags h env' cmms (lmdata ++ [lmdata'])
cmmDataLlvmGens' dflags h env' cmms (lmdata ++ [lmdata'])
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- | Do llvm code generation on all these cmms procs. -- | Do llvm code generation on all these cmms procs.
-- --
cmmProcLlvmGens cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop]
:: DynFlags
-> BufHandle
-> UniqSupply
-> LlvmEnv
-> [RawCmmTop]
-> Int -- ^ count, used for generating unique subsections -> Int -- ^ count, used for generating unique subsections
-> [LlvmVar] -- ^ info tables that need to be marked as 'used' -> [LlvmVar] -- ^ info tables that need to be marked as 'used'
-> IO () -> IO ()
...@@ -116,34 +90,28 @@ cmmProcLlvmGens ...@@ -116,34 +90,28 @@ cmmProcLlvmGens
cmmProcLlvmGens _ _ _ _ [] _ [] cmmProcLlvmGens _ _ _ _ [] _ []
= return () = return ()
cmmProcLlvmGens dflags h _ _ [] _ ivars cmmProcLlvmGens _ h _ _ [] _ ivars
= do = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr
let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr ty = (LMArray (length ivars) i8Ptr)
let ty = (LMArray (length ivars) i8Ptr) usedArray = LMStaticArray (map cast ivars) ty
let usedArray = LMStaticArray (map cast ivars) ty lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
let lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending
(Just $ fsLit "llvm.metadata") Nothing, Just usedArray) (Just $ fsLit "llvm.metadata") Nothing, Just usedArray)
Prt.bufLeftRender h $ pprLlvmData dflags ([lmUsed], []) in do
Prt.bufLeftRender h $ pprLlvmData ([lmUsed], [])
cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars
= do = 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 let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm
Prt.bufLeftRender h $ Prt.vcat docs 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. -- | Complete llvm code generation phase for a single top-level chunk of Cmm.
cmmLlvmGen cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop
:: DynFlags -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] )
-> UniqSupply
-> LlvmEnv
-> RawCmmTop -- ^ the cmm to generate code for
-> IO ( UniqSupply,
LlvmEnv,
[LlvmCmmTop] ) -- llvm code
cmmLlvmGen dflags us env cmm cmmLlvmGen dflags us env cmm
= do = do
...@@ -154,10 +122,10 @@ cmmLlvmGen dflags us env cmm ...@@ -154,10 +122,10 @@ cmmLlvmGen dflags us env cmm
(pprCmm $ Cmm [fixed_cmm]) (pprCmm $ Cmm [fixed_cmm])
-- generate llvm code from 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" 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) return (usGen, env', llvmBC)
...@@ -165,18 +133,9 @@ cmmLlvmGen dflags us env cmm ...@@ -165,18 +133,9 @@ cmmLlvmGen dflags us env cmm
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- | Instruction selection -- | Instruction selection
-- --
genLlvmCode genLlvmCode :: LlvmEnv -> RawCmmTop
:: DynFlags
-> LlvmEnv
-> RawCmmTop
-> UniqSM (LlvmEnv, [LlvmCmmTop]) -> UniqSM (LlvmEnv, [LlvmCmmTop])
genLlvmCode env (CmmData _ _ ) = return (env, [])
genLlvmCode _ env (CmmData _ _) genLlvmCode env (CmmProc _ _ _ (ListGraph [])) = return (env, [])
= return (env, []) genLlvmCode env cp@(CmmProc _ _ _ _ ) = genLlvmProc env cp
genLlvmCode _ env (CmmProc _ _ _ (ListGraph []))
= return (env, [])
genLlvmCode _ env cp@(CmmProc _ _ _ _)
= genLlvmProc env cp
...@@ -335,7 +335,8 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops) ...@@ -335,7 +335,8 @@ arg_vars env (CmmHinted e AddrHint:rest) (vars, stmts, tops)
++ show a ++ ")" ++ show a ++ ")"
(v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr (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) arg_vars env (CmmHinted e _:rest) (vars, stmts, tops)
= do (env', v1, stmts', top') <- exprToVar env e = do (env', v1, stmts', top') <- exprToVar env e
......
...@@ -15,7 +15,6 @@ import BlockId ...@@ -15,7 +15,6 @@ import BlockId
import CLabel import CLabel
import Cmm import Cmm
import DynFlags
import FastString import FastString
import qualified Outputable import qualified Outputable
...@@ -38,8 +37,8 @@ structStr = fsLit "_struct" ...@@ -38,8 +37,8 @@ structStr = fsLit "_struct"
-- complete this completely though as we need to pass all CmmStatic -- complete this completely though as we need to pass all CmmStatic
-- sections before all references can be resolved. This last step is -- sections before all references can be resolved. This last step is
-- done by 'resolveLlvmData'. -- done by 'resolveLlvmData'.
genLlvmData :: DynFlags -> (Section, [CmmStatic]) -> LlvmUnresData genLlvmData :: [CmmStatic] -> LlvmUnresData
genLlvmData _ ( _ , (CmmDataLabel lbl):xs) = genLlvmData (CmmDataLabel lbl:xs) =
let static = map genData xs let static = map genData xs
label = strCLabel_llvm lbl label = strCLabel_llvm lbl
...@@ -51,20 +50,20 @@ genLlvmData _ ( _ , (CmmDataLabel lbl):xs) = ...@@ -51,20 +50,20 @@ genLlvmData _ ( _ , (CmmDataLabel lbl):xs) =
alias = LMAlias (label `appendFS` structStr) strucTy alias = LMAlias (label `appendFS` structStr) strucTy
in (lbl, alias, static) 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]) -> (LlvmEnv, [LlvmData])
resolveLlvmDatas _ env [] ldata resolveLlvmDatas env [] ldata
= (env, ldata) = (env, ldata)
resolveLlvmDatas dflags env (udata : rest) ldata resolveLlvmDatas env (udata : rest) ldata
= let (env', ndata) = resolveLlvmData dflags env udata = let (env', ndata) = resolveLlvmData env udata
in resolveLlvmDatas dflags env' rest (ldata ++ [ndata]) in resolveLlvmDatas env' rest (ldata ++ [ndata])
-- | Fix up CLabel references now that we should have passed all CmmData. -- | Fix up CLabel references now that we should have passed all CmmData.
resolveLlvmData :: DynFlags -> LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData) resolveLlvmData :: LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
resolveLlvmData _ env (lbl, alias, unres) = resolveLlvmData env (lbl, alias, unres) =
let (env', static, refs) = resDatas env unres ([], []) let (env', static, refs) = resDatas env unres ([], [])
refs' = catMaybes refs refs' = catMaybes refs
struct = Just $ LMStaticStruc static alias struct = Just $ LMStaticStruc static alias
......
...@@ -15,7 +15,6 @@ import LlvmCodeGen.Data ...@@ -15,7 +15,6 @@ import LlvmCodeGen.Data
import CLabel import CLabel
import Cmm import Cmm
import DynFlags
import FastString import FastString
import Pretty import Pretty
import Unique import Unique
...@@ -61,14 +60,14 @@ pprLlvmHeader = moduleLayout ...@@ -61,14 +60,14 @@ pprLlvmHeader = moduleLayout
-- | Pretty print LLVM code -- | Pretty print LLVM code
pprLlvmCmmTop :: DynFlags -> LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar]) pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar])
pprLlvmCmmTop dflags _ _ (CmmData _ lmdata) pprLlvmCmmTop _ _ (CmmData _ lmdata)
= (vcat $ map (pprLlvmData dflags) 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 = let static = CmmDataLabel lbl : info
(idoc, ivar) = if not (null info) (idoc, ivar) = if not (null info)
then pprCmmStatic dflags env count static then pprCmmStatic env count static
else (empty, []) else (empty, [])
in (idoc $+$ ( in (idoc $+$ (
let sec = mkLayoutSection (count + 1) let sec = mkLayoutSection (count + 1)
...@@ -87,18 +86,18 @@ pprLlvmCmmTop dflags env count (CmmProc info lbl _ (ListGraph blks)) ...@@ -87,18 +86,18 @@ pprLlvmCmmTop dflags env count (CmmProc info lbl _ (ListGraph blks))
-- | Pretty print LLVM data code -- | Pretty print LLVM data code
pprLlvmData :: DynFlags -> LlvmData -> Doc pprLlvmData :: LlvmData -> Doc
pprLlvmData _ (globals, types) = pprLlvmData (globals, types) =
let globals' = ppLlvmGlobals globals let globals' = ppLlvmGlobals globals
types' = ppLlvmTypes types types' = ppLlvmTypes types
in types' $+$ globals' in types' $+$ globals'
-- | Pretty print CmmStatic -- | Pretty print CmmStatic
pprCmmStatic :: DynFlags -> LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar]) pprCmmStatic :: LlvmEnv -> Int -> [CmmStatic] -> (Doc, [LlvmVar])
pprCmmStatic dflags env count stat pprCmmStatic env count stat
= let unres = genLlvmData dflags (Data,stat) = let unres = genLlvmData stat
(_, (ldata, ltypes)) = resolveLlvmData dflags env unres (_, (ldata, ltypes)) = resolveLlvmData env unres
setSection (gv@(LMGlobalVar s ty l _ _), d) setSection (gv@(LMGlobalVar s ty l _ _), d)
= let v = if l == Internal then [gv] else [] = let v = if l == Internal then [gv] else []
...@@ -107,7 +106,7 @@ pprCmmStatic dflags env count stat ...@@ -107,7 +106,7 @@ pprCmmStatic dflags env count stat
setSection v = (v,[]) setSection v = (v,[])
(ldata', llvmUsed) = mapAndUnzip setSection ldata (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 -- | Create an appropriate section declaration for subsection <n> of text
......
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