X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen.hs;h=56d8386431f0c1202a8e0dabfd869cc76f6295a7;hp=c4848c90b181a0a5abd3324d013ccfb4c5e305f8;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=24a3fee9f3ff6cef6fe471ab6f0a7ba9ac001faf diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index c4848c9..56d8386 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -2,7 +2,7 @@ -- | This is the top-level module in the LLVM code generator. -- -module LlvmCodeGen ( llvmCodeGen ) where +module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" @@ -13,10 +13,12 @@ import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr +import LlvmMangler + import CLabel -import Cmm import CgUtils ( fixStgRegisters ) -import PprCmm +import OldCmm +import OldPprCmm import BufWrite import DynFlags @@ -26,89 +28,61 @@ import Outputable import qualified Pretty as Prt import UniqSupply import Util +import SysTools ( figureLlvmVersion ) +import Data.Maybe ( fromMaybe ) import System.IO -- ----------------------------------------------------------------------------- --- | Top-level of the llvm codegen +-- | Top-level of the LLVM Code generator -- 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 [] - - bFlush bufh - - return () + = let cmm = concat $ map (\(Cmm top) -> top) cmms + (cdata,env) = foldr split ([],initLlvmEnv) cmm + split (CmmData s d' ) (d,e) = ((s,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') + in do + bufh <- newBufHandle h + Prt.bufLeftRender bufh $ pprLlvmHeader + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + + env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] + cmmProcLlvmGens dflags bufh us env' cmm 1 [] + + bFlush bufh + return () -- ----------------------------------------------------------------------------- --- | Do llvm code generation on all these cmms data sections. +-- | 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 -> [(Section,[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. +-- | 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,35 +90,27 @@ 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 False, Just usedArray) + in 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 - +-- | Complete LLVM code generation phase for a single top-level chunk of Cmm. +cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop + -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] ) cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs @@ -154,29 +120,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 $ genLlvmProc 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) - --- ----------------------------------------------------------------------------- --- | 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 -