diff options
Diffstat (limited to 'compiler/llvmGen/LlvmCodeGen.hs')
| -rw-r--r-- | compiler/llvmGen/LlvmCodeGen.hs | 252 |
1 files changed, 142 insertions, 110 deletions
diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index a157a258fe..d0f343fa92 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -11,6 +11,7 @@ import LlvmCodeGen.Base import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr +import LlvmCodeGen.Regs import LlvmMangler import CgUtils ( fixStgRegisters ) @@ -23,142 +24,173 @@ import DynFlags import ErrUtils import FastString import Outputable -import qualified Pretty as Prt import UniqSupply -import Util import SysTools ( figureLlvmVersion ) +import qualified Stream import Control.Monad ( when ) import Data.IORef ( writeIORef ) -import Data.Maybe ( fromMaybe ) +import Data.Maybe ( fromMaybe, catMaybes ) import System.IO -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM Code generator -- -llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmmGroup] -> IO () -llvmCodeGen dflags h us cmms - = let cmm = concat cmms - (cdata,env) = {-# SCC "llvm_split" #-} - foldr split ([], initLlvmEnv dflags) cmm - split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split (CmmProc h l live g) (d,e) = - let lbl = strCLabel_llvm env $ - case mapLookup (g_entry g) h of - Nothing -> l - Just (Statics info_lbl _) -> info_lbl - env' = funInsert lbl (llvmFunTy dflags live) e - in (d,env') - in do - showPass dflags "LlVM CodeGen" - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" pprLlvmHeader - bufh <- newBufHandle h - Prt.bufLeftRender bufh $ withPprStyleDoc dflags (mkCodeStyle CStyle) pprLlvmHeader - ver <- getLlvmVersion - env' <- {-# SCC "llvm_datas_gen" #-} - cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] - {-# SCC "llvm_procs_gen" #-} - cmmProcLlvmGens dflags bufh us env' cmm 1 [] - bFlush bufh - return () - - where - -- | Handle setting up the LLVM version. - getLlvmVersion = do - ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags - -- cache llvm version for later use - writeIORef (llvmVersion dflags) ver - debugTraceMsg dflags 2 - (text "Using LLVM version:" <+> text (show ver)) - let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags - when (ver < minSupportLlvmVersion && doWarn) $ - errorMsg dflags (text "You are using an old version of LLVM that" - <> text " isn't supported anymore!" - $+$ text "We will try though...") - when (ver > maxSupportLlvmVersion && doWarn) $ - putMsg dflags (text "You are using a new version of LLVM that" - <> text " hasn't been tested yet!" - $+$ text "We will try though...") - return ver +llvmCodeGen :: DynFlags -> Handle -> UniqSupply + -> Stream.Stream IO RawCmmGroup () + -> IO () +llvmCodeGen dflags h us cmm_stream + = do bufh <- newBufHandle h + + -- Pass header + showPass dflags "LLVM CodeGen" + -- get llvm version, cache for later use + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + writeIORef (llvmVersion dflags) ver + + -- warn if unsupported + debugTraceMsg dflags 2 + (text "Using LLVM version:" <+> text (show ver)) + let doWarn = wopt Opt_WarnUnsupportedLlvmVersion dflags + when (ver < minSupportLlvmVersion && doWarn) $ + errorMsg dflags (text "You are using an old version of LLVM that" + <> text " isn't supported anymore!" + $+$ text "We will try though...") + when (ver > maxSupportLlvmVersion && doWarn) $ + putMsg dflags (text "You are using a new version of LLVM that" + <> text " hasn't been tested yet!" + $+$ text "We will try though...") + + -- run code generation + runLlvm dflags ver bufh us $ + llvmCodeGen' (liftStream cmm_stream) + + bFlush bufh + +llvmCodeGen' :: Stream.Stream LlvmM RawCmmGroup () -> LlvmM () +llvmCodeGen' cmm_stream + = do -- Preamble + renderLlvm pprLlvmHeader + ghcInternalFunctions + cmmMetaLlvmPrelude + + -- Procedures + let llvmStream = Stream.mapM llvmGroupLlvmGens cmm_stream + _ <- Stream.collect llvmStream + + -- Declare aliases for forward references + renderLlvm . pprLlvmData =<< generateAliases + + -- Postamble + cmmUsedLlvmGens + +llvmGroupLlvmGens :: RawCmmGroup -> LlvmM () +llvmGroupLlvmGens cmm = do + + -- Insert functions into map, collect data + let split (CmmData s d' ) = return $ Just (s, d') + split (CmmProc h l live g) = do + -- Set function type + let l' = case mapLookup (g_entry g) h of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl + lml <- strCLabel_llvm l' + funInsert lml =<< llvmFunTy live + return Nothing + cdata <- fmap catMaybes $ mapM split cmm + + {-# SCC "llvm_datas_gen" #-} + cmmDataLlvmGens cdata + {-# SCC "llvm_procs_gen" #-} + mapM_ cmmLlvmGen cmm -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] - -> [LlvmUnresData] -> IO ( LlvmEnv ) - -cmmDataLlvmGens dflags h env [] lmdata - = let (env', lmdata') = {-# SCC "llvm_resolve" #-} - resolveLlvmDatas env lmdata - lmdoc = {-# SCC "llvm_data_ppr" #-} - vcat $ map pprLlvmData lmdata' - in do - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" lmdoc - {-# SCC "llvm_data_out" #-} - Prt.bufLeftRender h $ withPprStyleDoc dflags (mkCodeStyle CStyle) lmdoc - return env' - -cmmDataLlvmGens dflags h env (cmm:cmms) 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' +cmmDataLlvmGens :: [(Section,CmmStatics)] -> LlvmM () +cmmDataLlvmGens statics + = do lmdatas <- mapM genLlvmData statics --- ----------------------------------------------------------------------------- --- | Do LLVM code generation on all these Cmms procs. --- -cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmDecl] - -> Int -- ^ count, used for generating unique subsections - -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used' - -> IO () - -cmmProcLlvmGens _ _ _ _ [] _ [] - = return () - -cmmProcLlvmGens dflags h _ _ [] _ ivars - = let ivars' = concat ivars - 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 $ {-# SCC "llvm_used_ppr" #-} - withPprStyleDoc dflags (mkCodeStyle CStyle) $ - pprLlvmData ([lmUsed], []) - -cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars - = cmmProcLlvmGens dflags h us env cmms count ivars - -cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do - (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm - let (docs, ivar) = mapAndUnzip (pprLlvmCmmDecl env' count) llvm - Prt.bufLeftRender h $ {-# SCC "llvm_proc_ppr" #-} - withPprStyleDoc dflags (mkCodeStyle CStyle) $ vcat docs - cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) + let (gss, tss) = unzip lmdatas + let regGlobal (LMGlobal (LMGlobalVar l ty _ _ _ _) _) + = funInsert l ty + regGlobal _ = return () + mapM_ regGlobal (concat gss) + + renderLlvm $ pprLlvmData (concat gss, concat tss) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. -cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmDecl - -> IO ( UniqSupply, LlvmEnv, [LlvmCmmDecl] ) -cmmLlvmGen dflags us env cmm = do +cmmLlvmGen ::RawCmmDecl -> LlvmM () +cmmLlvmGen cmm@CmmProc{} = do + -- rewrite assignments to global regs + dflags <- getDynFlag id let fixed_cmm = {-# SCC "llvm_fix_regs" #-} fixStgRegisters dflags cmm - dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmmGroup [fixed_cmm]) + dumpIfSetLlvm Opt_D_dump_opt_cmm "Optimised Cmm" (pprCmmGroup [fixed_cmm]) -- generate llvm code from cmm - let ((env', llvmBC), usGen) = {-# SCC "llvm_proc_gen" #-} - initUs us $ genLlvmProc env fixed_cmm + llvmBC <- withClearVars $ genLlvmProc fixed_cmm - dumpIfSet_dyn dflags Opt_D_dump_llvm "LLVM Code" - (vcat $ map (fst . pprLlvmCmmDecl env' 0) llvmBC) + -- allocate IDs for info table and code, so the mangler can later + -- make sure they end up next to each other. + itableSection <- freshSectionId + _codeSection <- freshSectionId - return (usGen, env', llvmBC) + -- pretty print + (docs, ivars) <- fmap unzip $ mapM (pprLlvmCmmDecl itableSection) llvmBC + + -- Output, note down used variables + renderLlvm (vcat docs) + mapM_ markUsedVar $ concat ivars + +cmmLlvmGen _ = return () + +-- ----------------------------------------------------------------------------- +-- | Generate meta data nodes +-- + +cmmMetaLlvmPrelude :: LlvmM () +cmmMetaLlvmPrelude = do + metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do + -- Generate / lookup meta data IDs + tbaaId <- getMetaUniqueId + setUniqMeta uniq tbaaId + parentId <- maybe (return Nothing) getUniqMeta parent + -- Build definition + return $ MetaUnamed tbaaId $ MetaStruct + [ MetaStr name + , case parentId of + Just p -> MetaNode p + Nothing -> MetaVar $ LMLitVar $ LMNullLit i8Ptr + ] + renderLlvm $ ppLlvmMetas metas + +-- ----------------------------------------------------------------------------- +-- | Marks variables as used where necessary +-- +cmmUsedLlvmGens :: LlvmM () +cmmUsedLlvmGens = do + + -- LLVM would discard variables that are internal and not obviously + -- used if we didn't provide these hints. This will generate a + -- definition of the form + -- + -- @llvm.used = appending global [42 x i8*] [i8* bitcast <var> to i8*, ...] + -- + -- Which is the LLVM way of protecting them against getting removed. + ivars <- getUsedVars + let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars) i8Ptr) + usedArray = LMStaticArray (map cast ivars) ty + sectName = Just $ fsLit "llvm.metadata" + lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending sectName Nothing Constant + lmUsed = LMGlobal lmUsedVar (Just usedArray) + if null ivars + then return () + else renderLlvm $ pprLlvmData ([lmUsed], []) |