X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FllvmGen%2FLlvmCodeGen.hs;h=56d8386431f0c1202a8e0dabfd869cc76f6295a7;hp=e0485e703c8cb4c763f046eb3c560f17c2af2639;hb=f8f0e76ad302fda30196ebc9230e5fcbc97be537;hpb=49a8e5c021009430d373d6224b29004c7d18c408 diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index e0485e7..56d8386 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -2,133 +2,115 @@ -- | This is the top-level module in the LLVM code generator. -- -module LlvmCodeGen ( llvmCodeGen ) where +module LlvmCodeGen ( llvmCodeGen, llvmFixupAsm ) where #include "HsVersions.h" +import Llvm + import LlvmCodeGen.Base import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr -import Cmm +import LlvmMangler + +import CLabel import CgUtils ( fixStgRegisters ) -import PprCmm +import OldCmm +import OldPprCmm import BufWrite import DynFlags import ErrUtils +import FastString 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 extractRawCmm cmms - - bufh <- newBufHandle h - - Prt.bufLeftRender bufh $ pprLlvmHeader - - env <- cmmDataLlvmGens dflags bufh cmm - cmmProcLlvmGens dflags bufh us env cmm - - bFlush bufh - - return () - - where extractRawCmm (Cmm tops) = tops + = 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 _ l _ _) = [(strCLabel_llvm l)] - exProclbl _ = [] - - cdata = concat $ map exData cmm - -- put the functions into the enviornment - cproc = concat $ map exProclbl 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 () -cmmProcLlvmGens _ _ _ _ [] - = return () +cmmProcLlvmGens _ _ _ _ [] _ [] + = return () -cmmProcLlvmGens dflags h us env (cmm : cmms) - = do - (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm +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], []) - Prt.bufLeftRender h $ Prt.vcat $ map (pprLlvmCmmTop dflags) llvm +cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars + = do + (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm - cmmProcLlvmGens dflags h us' env' cmms + 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) --- | 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 @@ -138,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 . pprLlvmCmmTop dflags) 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 -