From a948fe838bc79363d7565033d6ee42bf24d52fdc Mon Sep 17 00:00:00 2001 From: Peter Wortmann Date: Wed, 26 Jun 2013 15:45:16 +0100 Subject: [PATCH] Major Llvm refactoring This combined patch reworks the LLVM backend in a number of ways: 1. Most prominently, we introduce a LlvmM monad carrying the contents of the old LlvmEnv around. This patch completely removes LlvmEnv and refactors towards standard library monad combinators wherever possible. 2. Support for streaming - we can now generate chunks of Llvm for Cmm as it comes in. This might improve our speed. 3. To allow streaming, we need a more flexible way to handle forward references. The solution (getGlobalPtr) unifies LlvmCodeGen.Data and getHsFunc as well. 4. Skip alloca-allocation for registers that are actually never written. LLVM will automatically eliminate these, but output is smaller and friendlier to human eyes this way. 5. We use LlvmM to collect references for llvm.used. This allows places other than cmmProcLlvmGens to generate entries. --- compiler/llvmGen/Llvm/Types.hs | 2 + compiler/llvmGen/LlvmCodeGen.hs | 253 +++--- compiler/llvmGen/LlvmCodeGen/Base.hs | 393 ++++++-- compiler/llvmGen/LlvmCodeGen/CodeGen.hs | 1105 ++++++++++++----------- compiler/llvmGen/LlvmCodeGen/Data.hs | 153 +--- compiler/llvmGen/LlvmCodeGen/Ppr.hs | 82 +- compiler/llvmGen/LlvmCodeGen/Regs.hs | 55 +- compiler/main/CodeOutput.lhs | 6 +- 8 files changed, 1104 insertions(+), 945 deletions(-) diff --git a/compiler/llvmGen/Llvm/Types.hs b/compiler/llvmGen/Llvm/Types.hs index c93147f4d013..6b9c8c181a26 100644 --- a/compiler/llvmGen/Llvm/Types.hs +++ b/compiler/llvmGen/Llvm/Types.hs @@ -623,6 +623,8 @@ data LlvmLinkageType -- | Alias for 'ExternallyVisible' but with explicit textual form in LLVM -- assembly. | External + -- | Symbol is private to the module and should not appear in the symbol table + | Private deriving (Eq) instance Outputable LlvmLinkageType where diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index f70693d53d87..4c5fa6513f12 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,143 +24,175 @@ import DynFlags import ErrUtils import FastString import Outputable -import qualified Pretty as Prt import UniqSupply -import Util import SysTools ( figureLlvmVersion ) +import MonadUtils +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 dflags h _ _ [] _ ivars - | null ivars' = return () - | otherwise = Prt.bufLeftRender h $ - {-# SCC "llvm_used_ppr" #-} - withPprStyleDoc dflags (mkCodeStyle CStyle) $ - pprLlvmData ([lmUsed], []) - where - ivars' = concat ivars - cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars') i8Ptr) - usedArray = LMStaticArray (map cast ivars') ty - lmUsedVar = LMGlobalVar (fsLit "llvm.used") ty Appending - (Just $ fsLit "llvm.metadata") Nothing Global - lmUsed = LMGlobal lmUsedVar (Just usedArray) - -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" + liftIO $ dumpIfSet_dyn dflags 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 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], []) diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 8de52eb0ba15..95d3abdc27a3 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -13,15 +13,23 @@ module LlvmCodeGen.Base ( LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion, maxSupportLlvmVersion, - LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, - funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform, - getDflags, ghcInternalFunctions, + LlvmM, + runLlvm, liftStream, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, + renderLlvm, runUs, markUsedVar, getUsedVars, + ghcInternalFunctions, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, + freshSectionId, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, llvmPtrBits, mkLlvmFunc, tysToParams, - strCLabel_llvm, genCmmLabelRef, genStringLabelRef + strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, + getGlobalPtr, generateAliases, ) where @@ -36,9 +44,16 @@ import DynFlags import FastString import Cmm import qualified Outputable as Outp +import qualified Pretty as Prt import Platform import UniqFM import Unique +import MonadUtils ( MonadIO(..) ) +import BufWrite ( BufHandle ) +import UniqSet +import UniqSupply +import ErrUtils +import qualified Stream -- ---------------------------------------------------------------------------- -- * Some Data Types @@ -93,30 +108,32 @@ llvmGhcCC dflags | otherwise = CC_Ncc 10 -- | Llvm Function type for Cmm function -llvmFunTy :: DynFlags -> LiveGlobalRegs -> LlvmType -llvmFunTy dflags live = LMFunction $ llvmFunSig' dflags live (fsLit "a") ExternallyVisible +llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible -- | Llvm Function signature -llvmFunSig :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig env live lbl link - = llvmFunSig' (getDflags env) live (strCLabel_llvm env lbl) link - -llvmFunSig' :: DynFlags -> LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmFunctionDecl -llvmFunSig' dflags live lbl link - = let toParams x | isPointer x = (x, [NoAlias, NoCapture]) - | otherwise = (x, []) - in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs - (map (toParams . getVarType) (llvmFunArgs dflags live)) - (llvmFunAlign dflags) +llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig live lbl link = do + lbl' <- strCLabel_llvm lbl + llvmFunSig' live lbl' link + +llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl +llvmFunSig' live lbl link + = do let toParams x | isPointer x = (x, [NoAlias, NoCapture]) + | otherwise = (x, []) + dflags <- getDynFlags + return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs + (map (toParams . getVarType) (llvmFunArgs dflags live)) + (llvmFunAlign dflags) -- | Create a Haskell function in LLVM. -mkLlvmFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks - -> LlvmFunction -mkLlvmFunc env live lbl link sec blks - = let dflags = getDflags env - funDec = llvmFunSig env live lbl link - funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live) - in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks +mkLlvmFunc :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks + -> LlvmM LlvmFunction +mkLlvmFunc live lbl link sec blks + = do funDec <- llvmFunSig live lbl link + dflags <- getDynFlags + let funArgs = map (fsLit . Outp.showSDoc dflags . ppPlainName) (llvmFunArgs dflags live) + return $ LlvmFunction funDec funArgs llvmStdFunAttrs sec blks -- | Alignment to use for functions llvmFunAlign :: DynFlags -> LMAlign @@ -172,96 +189,276 @@ maxSupportLlvmVersion = 33 -- * Environment Handling -- --- two maps, one for functions and one for local vars. -newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags) +data LlvmEnv = LlvmEnv + { envFunMap :: LlvmEnvMap + , envVarMap :: LlvmEnvMap + , envStackRegs :: [GlobalReg] + , envUsedVars :: [LlvmVar] + , envAliases :: UniqSet LMString + , envLabelMap :: [(CLabel, CLabel)] + , envVersion :: LlvmVersion + , envDynFlags :: DynFlags + , envOutput :: BufHandle + , envUniq :: UniqSupply + , envFreshMeta :: Int + , envUniqMeta :: UniqFM Int + , envNextSection :: Int + } type LlvmEnvMap = UniqFM LlvmType --- | Get initial Llvm environment. -initLlvmEnv :: DynFlags -> LlvmEnv -initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags) - where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions dflags ] +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } +instance Monad LlvmM where + return x = LlvmM $ \env -> return (x, env) + m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env + runLlvmM (f x) env' +instance Functor LlvmM where + fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env + return (f x, env') +instance MonadIO LlvmM where + liftIO m = LlvmM $ \env -> do x <- m + return (x, env) + +instance HasDynFlags LlvmM where + getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) --- | Here we pre-initialise some functions that are used internally by GHC --- so as to make sure they have the most general type in the case that --- user code also uses these functions but with a different type than GHC --- internally. (Main offender is treating return type as 'void' instead of --- 'void *'. Fixes trac #5486. -ghcInternalFunctions :: DynFlags -> [(LMString, LlvmFunctionDecl)] -ghcInternalFunctions dflags = - [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] - , mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] - , mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] - ] - where - mk n ret args = - let n' = fsLit n - in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret - FixedArgs (tysToParams args) Nothing) - --- | Clear variables from the environment. -clearVars :: LlvmEnv -> LlvmEnv -clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-} - LlvmEnv (e1, emptyUFM, n, p) - --- | Insert local variables into the environment. -varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-} - LlvmEnv (e1, addToUFM e2 s t, n, p) - --- | Insert functions into the environment. -funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-} - LlvmEnv (addToUFM e1 s t, e2, n, p) - --- | Lookup local variables in the environment. -varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-} - lookupUFM e2 s - --- | Lookup functions in the environment. -funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-} - lookupUFM e1 s +-- | Get initial Llvm environment. +runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO () +runLlvm dflags ver out us m = do + _ <- runLlvmM m env + return () + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envLabelMap = [] + , envVersion = ver + , envDynFlags = dflags + , envOutput = out + , envUniq = us + , envFreshMeta = 0 + , envUniqMeta = emptyUFM + , envNextSection = 1 + } + +-- | Get environment (internal) +getEnv :: (LlvmEnv -> a) -> LlvmM a +getEnv f = LlvmM (\env -> return (f env, env)) + +-- | Modify environment (internal) +modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM () +modifyEnv f = LlvmM (\env -> return ((), f env)) + +-- | Lift a stream into the LlvmM monad +liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x +liftStream s = Stream.Stream $ do + r <- liftIO $ Stream.runStream s + case r of + Left b -> return (Left b) + Right (a, r2) -> return (Right (a, liftStream r2)) + +-- | Clear variables from the environment for a subcomputation +withClearVars :: LlvmM a -> LlvmM a +withClearVars m = LlvmM $ \env -> do + (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] } + return (x, env' { envVarMap = emptyUFM, envStackRegs = [] }) + +-- | Insert variables or functions into the environment. +varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM () +varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t } +funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t } + +-- | Lookup variables or functions in the environment. +varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType) +varLookup s = getEnv (flip lookupUFM s . envVarMap) +funLookup s = getEnv (flip lookupUFM s . envFunMap) + +-- | Set a register as allocated on the stack +markStackReg :: GlobalReg -> LlvmM () +markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env } + +-- | Check whether a register is allocated on the stack +checkStackReg :: GlobalReg -> LlvmM Bool +checkStackReg r = getEnv ((elem r) . envStackRegs) + +-- | Allocate a new global unnamed metadata identifier +getMetaUniqueId :: LlvmM Int +getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1}) -- | Get the LLVM version we are generating code for -getLlvmVer :: LlvmEnv -> LlvmVersion -getLlvmVer (LlvmEnv (_, _, n, _)) = n +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion --- | Set the LLVM version we are generating code for -setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv -setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p) +-- | Get the platform we are generating code for +getDynFlag :: (DynFlags -> a) -> LlvmM a +getDynFlag f = getEnv (f . envDynFlags) -- | Get the platform we are generating code for -getLlvmPlatform :: LlvmEnv -> Platform -getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d +getLlvmPlatform :: LlvmM Platform +getLlvmPlatform = getDynFlag targetPlatform + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.SDoc -> LlvmM () +renderLlvm sdoc = LlvmM $ \env -> do + + -- Write to output + let doc = Outp.withPprStyleDoc (envDynFlags env) (Outp.mkCodeStyle Outp.CStyle) sdoc + Prt.bufLeftRender (envOutput env) doc + + -- Dump, if requested + dumpIfSet_dyn (envDynFlags env) Opt_D_dump_llvm "LLVM Code" sdoc + return ((), env) + +-- | Run a @UniqSM@ action with our unique supply +runUs :: UniqSM a -> LlvmM a +runUs m = LlvmM $ \env -> do + let (x, us') = initUs (envUniq env) m + return (x, env { envUniq = us' }) + +-- | Marks a variable as "used" +markUsedVar :: LlvmVar -> LlvmM () +markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env } + +-- | Return all variables marked as "used" so far +getUsedVars :: LlvmM [LlvmVar] +getUsedVars = getEnv envUsedVars + +-- | Saves that at some point we didn't know the type of the label and +-- generated a reference to a type variable instead +saveAlias :: LMString -> LlvmM () +saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl } + +-- | Sets metadata node for a given unique +setUniqMeta :: Unique -> Int -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe Int) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- | Returns a fresh section ID +freshSectionId :: LlvmM Int +freshSectionId = LlvmM $ \env -> return (envNextSection env, env { envNextSection = envNextSection env + 1}) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- --- | Get the DynFlags for this compilation pass -getDflags :: LlvmEnv -> DynFlags -getDflags (LlvmEnv (_, _, _, d)) = d +-- | Here we pre-initialise some functions that are used internally by GHC +-- so as to make sure they have the most general type in the case that +-- user code also uses these functions but with a different type than GHC +-- internally. (Main offender is treating return type as 'void' instead of +-- 'void *'). Fixes trac #5486. +ghcInternalFunctions :: LlvmM () +ghcInternalFunctions = do + dflags <- getDynFlags + mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags] + mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags] + mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr] + where + mk n ret args = do + let n' = fsLit n + decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret + FixedArgs (tysToParams args) Nothing + renderLlvm $ ppLlvmFunctionDecl decl + funInsert n' (LMFunction decl) -- ---------------------------------------------------------------------------- -- * Label handling -- -- | Pretty print a 'CLabel'. -strCLabel_llvm :: LlvmEnv -> CLabel -> LMString -strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-} - (fsLit . toString . pprCLabel (getLlvmPlatform env)) l - where dflags = getDflags env - style = Outp.mkCodeStyle Outp.CStyle - toString doc = Outp.renderWithStyle dflags doc style - --- | Create an external definition for a 'CLabel' defined in another module. -genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal -genCmmLabelRef env = genStringLabelRef (getDflags env) . strCLabel_llvm env - --- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'. -genStringLabelRef :: DynFlags -> LMString -> LMGlobal -genStringLabelRef dflags cl - = let ty = LMPointer $ LMArray 0 (llvmWord dflags) - in LMGlobal (LMGlobalVar cl ty External Nothing Nothing Global) Nothing +strCLabel_llvm :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) + return (fsLit str) + +strDisplayName_llvm :: CLabel -> LlvmM LMString +strDisplayName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle (const Outp.NameNotInScope2, const True) depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit (dropInfoSuffix str)) + +dropInfoSuffix :: String -> String +dropInfoSuffix = go + where go "_info" = [] + go "_static_info" = [] + go "_con_info" = [] + go (x:xs) = x:go xs + go [] = [] + +strProcedureName_llvm :: CLabel -> LlvmM LMString +strProcedureName_llvm lbl = do + platform <- getLlvmPlatform + dflags <- getDynFlags + let sdoc = pprCLabel platform lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle (const Outp.NameUnqual, const False) depth + str = Outp.renderWithStyle dflags sdoc style + return (fsLit str) + +-- ---------------------------------------------------------------------------- +-- * Global variables / forward references +-- + +-- | Create/get a pointer to a global value. Might return an alias if +-- the value in question hasn't been defined yet. We especially make +-- no guarantees on the type of the returned pointer. +getGlobalPtr :: LMString -> LlvmM LlvmVar +getGlobalPtr llvmLbl = do + m_ty <- funLookup llvmLbl + let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing + case m_ty of + -- Directly reference if we have seen it already + Just ty -> return $ mkGlbVar llvmLbl ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar (llvmLbl `appendFS` fsLit "$alias") i8 Alias + +-- | Generate definitions for aliases forward-referenced by @getGlobalPtr@. +-- +-- Must be called at a point where we are sure that no new global definitions +-- will be generated anymore! +generateAliases :: LlvmM ([LMGlobal], [LlvmType]) +generateAliases = do + delayed <- fmap uniqSetToList $ getEnv envAliases + defss <- flip mapM delayed $ \lbl -> do + let var ty = LMGlobalVar lbl (LMPointer ty) External Nothing Nothing Global + aliasLbl = lbl `appendFS` fsLit "$alias" + aliasVar = LMGlobalVar aliasLbl i8Ptr Private Nothing Nothing Alias + -- If we have a definition, set the alias value using a + -- cost. Otherwise, declare it as an undefined external symbol. + m_ty <- funLookup lbl + case m_ty of + Just ty -> return [LMGlobal aliasVar $ Just $ LMBitc (LMStaticPointer (var ty)) i8Ptr] + Nothing -> return [LMGlobal (var i8) Nothing, + LMGlobal aliasVar $ Just $ LMStaticPointer (var i8) ] + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- Note [Llvm Forward References] +-- +-- The issue here is that LLVM insists on being strongly typed at +-- every corner, so the first time we mention something, we have to +-- settle what type we assign to it. That makes things awkward, as Cmm +-- will often reference things before their definition, and we have no +-- idea what (LLVM) type it is going to be before that point. +-- +-- Our work-around is to define "aliases" of a standard type (i8 *) in +-- these kind of situations, which we later tell LLVM to be either +-- references to their actual local definitions (involving a cast) or +-- an external reference. This obviously only works for pointers. -- ---------------------------------------------------------------------------- -- * Misc diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index d6bd86400324..6e372fd61b77 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -29,232 +29,232 @@ import Platform import OrdList import UniqSupply import Unique -import Util -import Data.List ( partition ) +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- -genLlvmProc :: LlvmEnv -> RawCmmDecl -> UniqSM (LlvmEnv, [LlvmCmmDecl]) -genLlvmProc env (CmmProc infos lbl live graph) = do +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do let blocks = toBlockListEntryFirstFalseFallthrough graph - (env', lmblocks, lmdata) <- basicBlocksCodeGen env live blocks ([], []) + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks let info = mapLookup (g_entry graph) infos proc = CmmProc info lbl live (ListGraph lmblocks) - return (env', proc:lmdata) + return (proc:lmdata) -genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" +genLlvmProc _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation -- --- | Generate code for a list of blocks that make up a complete procedure. -basicBlocksCodeGen :: LlvmEnv - -> LiveGlobalRegs - -> [CmmBlock] - -> ( [LlvmBasicBlock] , [LlvmCmmDecl] ) - -> UniqSM (LlvmEnv, [LlvmBasicBlock] , [LlvmCmmDecl] ) -basicBlocksCodeGen env live [] (blocks0, tops0) - = return (env, fblocks, tops) - where - dflags = getDflags env - blocks = reverse blocks0 - tops = reverse tops0 - (blocks', allocs) = mapAndUnzip dominateAllocs blocks - allocs' = concat allocs - (BasicBlock id fstmts : rblks) = blocks' - fblocks = (BasicBlock id $ funPrologue dflags live ++ allocs' ++ fstmts):rblks - -basicBlocksCodeGen env live (block:blocks) (lblocks, ltops) - = do (env', lb, lt) <- basicBlockCodeGen env block - basicBlocksCodeGen env' live blocks (lb : lblocks, reverse lt ++ ltops) +-- | Generate code for a list of blocks that make up a complete +-- procedure. The first block in the list is exepected to be the entry +-- point and will get the prologue. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live (entryBlock:cmmBlocks) + = do (prologue, prologueTops) <- funPrologue live (entryBlock:cmmBlocks) + -- Generate code + (BasicBlock bid entry, entryTops) <- basicBlockCodeGen entryBlock + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks --- | Allocations need to be extracted so they can be moved to the entry --- of a function to make sure they dominate all possible paths in the CFG. -dominateAllocs :: LlvmBasicBlock -> (LlvmBasicBlock, [LlvmStatement]) -dominateAllocs (BasicBlock id stmts) - = let (allocs, stmts') = partition isAlloc stmts - isAlloc (Assignment _ (Alloca _ _)) = True - isAlloc _other = False - in (BasicBlock id stmts', allocs) + -- Compose + let entryBlock = BasicBlock bid (fromOL prologue ++ entry) + return (entryBlock : blocks, prologueTops ++ entryTops ++ concat topss) -- | Generate code for one block -basicBlockCodeGen :: LlvmEnv - -> CmmBlock - -> UniqSM ( LlvmEnv, LlvmBasicBlock, [LlvmCmmDecl] ) -basicBlockCodeGen env block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen block = do let (CmmEntry id, nodes, tail) = blockSplit block - let stmts = blockToList nodes - (env', mid_instrs, top) <- stmtsToInstrs env stmts (nilOL, []) - (env'', tail_instrs, top') <- stmtToInstrs env' tail + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail let instrs = fromOL (mid_instrs `appOL` tail_instrs) - return (env'', BasicBlock id instrs, top' ++ top) + return (BasicBlock id instrs, top' ++ top) -- ----------------------------------------------------------------------------- -- * CmmNode code generation -- -- A statement conversion return data. --- * LlvmEnv: The new environment -- * LlvmStatements: The compiled LLVM statements. -- * LlvmCmmDecl: Any global data needed. -type StmtData = (LlvmEnv, LlvmStatements, [LlvmCmmDecl]) +type StmtData = (LlvmStatements, [LlvmCmmDecl]) -- | Convert a list of CmmNode's to LlvmStatement's -stmtsToInstrs :: LlvmEnv -> [CmmNode e x] -> (LlvmStatements, [LlvmCmmDecl]) - -> UniqSM StmtData -stmtsToInstrs env [] (llvm, top) - = return (env, llvm, top) - -stmtsToInstrs env (stmt : stmts) (llvm, top) - = do (env', instrs, tops) <- stmtToInstrs env stmt - stmtsToInstrs env' stmts (llvm `appOL` instrs, top ++ tops) +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) --- | Convert a CmmNode to a list of LlvmStatement's -stmtToInstrs :: LlvmEnv -> CmmNode e x - -> UniqSM StmtData -stmtToInstrs env stmt = case stmt of +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of - CmmComment _ -> return (env, nilOL, []) -- nuke comments + CmmComment _ -> return (nilOL, []) -- nuke comments - CmmAssign reg src -> genAssign env reg src - CmmStore addr src -> genStore env addr src + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src - CmmBranch id -> genBranch env id - CmmCondBranch arg true false -> genCondBranch env arg true false - CmmSwitch arg ids -> genSwitch env arg ids + CmmBranch id -> genBranch id + CmmCondBranch arg true false + -> genCondBranch arg true false + CmmSwitch arg ids -> genSwitch arg ids -- Foreign Call - CmmUnsafeForeignCall target res args -> genCall env target res args + CmmUnsafeForeignCall target res args + -> genCall target res args -- Tail call CmmCall { cml_target = arg, - cml_args_regs = live } -> genJump env arg live + cml_args_regs = live } -> genJump arg live _ -> panic "Llvm.CodeGen.stmtToInstrs" +-- | Wrapper function to declare an instrinct function by function type +getInstrinct2 :: LMString -> LlvmType -> LlvmM ExprData +getInstrinct2 fname fty@(LMFunction funSig) = do + + let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Constant + + fn <- funLookup fname + tops <- case fn of + Just _ -> + return [] + Nothing -> do + funInsert fname fty + return [CmmData Data [([],[fty])]] + + return (fv, nilOL, tops) + +getInstrinct2 _ _ = error "getInstrinct2: Non-function type!" + +-- | Declares an instrinct function by return and parameter types +getInstrinct :: LMString -> LlvmType -> [LlvmType] -> LlvmM ExprData +getInstrinct fname retTy parTys = + let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc retTy + FixedArgs (tysToParams parTys) Nothing + fty = LMFunction funSig + in getInstrinct2 fname fty + -- | Memory barrier instruction for LLVM >= 3.0 -barrier :: LlvmEnv -> UniqSM StmtData -barrier env = do +barrier :: LlvmM StmtData +barrier = do let s = Fence False SyncSeqCst - return (env, unitOL s, []) + return (unitOL s, []) -- | Memory barrier instruction for LLVM < 3.0 -oldBarrier :: LlvmEnv -> UniqSM StmtData -oldBarrier env = do - let dflags = getDflags env - let fname = fsLit "llvm.memory.barrier" - let funSig = LlvmFunctionDecl fname ExternallyVisible CC_Ccc LMVoid - FixedArgs (tysToParams [i1, i1, i1, i1, i1]) (llvmFunAlign dflags) - let fty = LMFunction funSig - - let fv = LMGlobalVar fname fty (funcLinkage funSig) Nothing Nothing Global - let tops = case funLookup fname env of - Just _ -> [] - Nothing -> [CmmData Data [([],[fty])]] +oldBarrier :: LlvmM StmtData +oldBarrier = do + + (fv, _, tops) <- getInstrinct (fsLit "llvm.memory.barrier") LMVoid [i1, i1, i1, i1, i1] let args = [lmTrue, lmTrue, lmTrue, lmTrue, lmTrue] let s1 = Expr $ Call StdCall fv args llvmStdFunAttrs - let env' = funInsert fname fty env - return (env', unitOL s1, tops) + return (unitOL s1, tops) where lmTrue :: LlvmVar lmTrue = mkIntLit i1 (-1) -- | Foreign Calls -genCall :: LlvmEnv -> ForeignTarget -> [CmmFormal] -> [CmmActual] - -> UniqSM StmtData +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM -- intrinsic function. -genCall env (PrimTarget MO_WriteBarrier) _ _ - | platformArch (getLlvmPlatform env) `elem` [ArchX86, ArchX86_64, ArchSPARC] - = return (env, nilOL, []) - | getLlvmVer env > 29 = barrier env - | otherwise = oldBarrier env - -genCall env (PrimTarget MO_Touch) _ _ - = return (env, nilOL, []) - -genCall env (PrimTarget (MO_UF_Conv w)) [dst] [e] = do - let (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) - ty = cmmToLlvmType $ localRegType dst +genCall (PrimTarget MO_WriteBarrier) _ _ = do + platform <- getLlvmPlatform + ver <- getLlvmVer + case () of + _ | platformArch platform `elem` [ArchX86, ArchX86_64, ArchSPARC] + -> return (nilOL, []) + | ver > 29 -> barrier + | otherwise -> oldBarrier + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = do + dstV <- getCmmReg (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst width = widthToLlvmFloat w castV <- mkLocalVar ty - (env2, ve, stmts2, top2) <- exprToVar env1 e + (ve, stmts, top) <- exprToVar e let stmt3 = Assignment castV $ Cast LM_Uitofp ve width stmt4 = Store castV dstV - stmts = stmts1 `appOL` stmts2 `snocOL` stmt3 `snocOL` stmt4 - return (env2, stmts, top1 ++ top2) + return (stmts `snocOL` stmt3 `snocOL` stmt4, top) -genCall _ (PrimTarget (MO_UF_Conv _)) [_] args = +genCall (PrimTarget (MO_UF_Conv _)) [_] args = panic $ "genCall: Too many arguments to MO_UF_Conv. " ++ "Can only handle 1, given" ++ show (length args) ++ "." -- Handle prefetching data -genCall env t@(PrimTarget MO_Prefetch_Data) [] args = do - let dflags = getDflags env - argTy = [i8Ptr, i32, i32, i32] +genCall t@(PrimTarget MO_Prefetch_Data) [] args = do + let argTy = [i8Ptr, i32, i32, i32] funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing let (_, arg_hints) = foreignTargetHints t let args_hints' = zip args arg_hints - (env1, argVars, stmts1, top1) <- arg_vars env args_hints' ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars dflags $ zip argVars argTy + (argVars, stmts1, top1) <- arg_vars args_hints' ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + trash <- getTrashStmts let arguments = argVars' ++ [mkIntLit i32 0, mkIntLit i32 3, mkIntLit i32 1] call = Expr $ Call StdCall fptr arguments [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) + `appOL` trash `snocOL` call + return (stmts, top1 ++ top2) -- Handle popcnt function specifically since GHC only really has i32 and i64 -- types and things like Word8 are backed by an i32 and just present a logical -- i8 range. So we must handle conversions from i32 to i8 explicitly as LLVM -- is strict about types. -genCall env t@(PrimTarget (MO_PopCnt w)) [dst] args = do - let dflags = getDflags env - width = widthToLlvmInt w +genCall t@(PrimTarget op@(MO_PopCnt w)) [dst] args = do + let width = widthToLlvmInt w dstTy = cmmToLlvmType $ localRegType dst - funTy = \n -> LMFunction $ LlvmFunctionDecl n ExternallyVisible - CC_Ccc width FixedArgs (tysToParams [width]) Nothing - (env1, dstV, stmts1, top1) = getCmmReg env (CmmLocal dst) + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width [width] + + dstV <- getCmmReg (CmmLocal dst) let (_, arg_hints) = foreignTargetHints t let args_hints = zip args arg_hints - (env2, argsV, stmts2, top2) <- arg_vars env1 args_hints ([], nilOL, []) - (env3, fptr, stmts3, top3) <- getFunPtr env2 funTy t - (argsV', stmts4) <- castVars dflags $ zip argsV [width] + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars $ zip argsV [width] (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] - ([retV'], stmts5) <- castVars dflags [(retV,dstTy)] + ([retV'], stmts5) <- castVars [(retV,dstTy)] let s2 = Store retV' dstV - let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` + let stmts = stmts2 `appOL` stmts4 `snocOL` s1 `appOL` stmts5 `snocOL` s2 - return (env3, stmts, top1 ++ top2 ++ top3) + return (stmts, top2 ++ top3) -- Handle memcpy function specifically since llvm's intrinsic version takes -- some extra parameters. -genCall env t@(PrimTarget op) [] args' +genCall t@(PrimTarget op) [] args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = do - let dflags = getDflags env - (args, alignVal) = splitAlignVal args' - (isVolTy, isVolVal) = if getLlvmVer env >= 28 - then ([i1], [mkIntLit i1 0]) else ([], []) + ver <- getLlvmVer + dflags <- getDynFlags + let (args, alignVal) = splitAlignVal args' + (isVolTy, isVolVal) + | ver >= 28 = ([i1], [mkIntLit i1 0]) + | otherwise = ([], []) argTy | op == MO_Memset = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible @@ -262,16 +262,16 @@ genCall env t@(PrimTarget op) [] args' let (_, arg_hints) = foreignTargetHints t let args_hints = zip args arg_hints - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t - (argVars', stmts3) <- castVars dflags $ zip argVars argTy + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + stmts4 <- getTrashStmts let arguments = argVars' ++ (alignVal:isVolVal) call = Expr $ Call StdCall fptr arguments [] stmts = stmts1 `appOL` stmts2 `appOL` stmts3 - `appOL` trashStmts (getDflags env) `snocOL` call - return (env2, stmts, top1 ++ top2) - + `appOL` stmts4 `snocOL` call + return (stmts, top1 ++ top2) where splitAlignVal xs = (init xs, extractLit $ last xs) @@ -284,9 +284,9 @@ genCall env t@(PrimTarget op) [] args' mkIntLit i32 0 -- Handle all other foreign calls and prim ops. -genCall env target res args = do +genCall target res args = do - let dflags = getDflags env + dflags <- getDynFlags -- parameter types let arg_type (_, AddrHint) = i8Ptr @@ -301,10 +301,11 @@ genCall env target res args = do ++ " 0 or 1, given " ++ show (length t) ++ "." -- extract Cmm call convention, and translate to LLVM call convention + platform <- getLlvmPlatform let lmconv = case target of ForeignTarget _ (ForeignConvention conv _ _ _) -> case conv of - StdCallConv -> case platformArch (getLlvmPlatform env) of + StdCallConv -> case platformArch platform of ArchX86 -> CC_X86_Stdcc ArchX86_64 -> CC_X86_Stdcc _ -> CC_Ccc @@ -341,22 +342,22 @@ genCall env target res args = do lmconv retTy FixedArgs argTy (llvmFunAlign dflags) - - (env1, argVars, stmts1, top1) <- arg_vars env args_hints ([], nilOL, []) - (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target + (argVars, stmts1, top1) <- arg_vars args_hints ([], nilOL, []) + (fptr, stmts2, top2) <- getFunPtr funTy target let retStmt | ccTy == TailCall = unitOL $ Return Nothing | never_returns = unitOL $ Unreachable | otherwise = nilOL - let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts (getDflags env) + stmts3 <- getTrashStmts + let stmts = stmts1 `appOL` stmts2 `appOL` stmts3 -- make the actual call case retTy of LMVoid -> do let s1 = Expr $ Call ccTy fptr argVars fnAttrs let allStmts = stmts `snocOL` s1 `appOL` retStmt - return (env2, allStmts, top1 ++ top2) + return (allStmts, top1 ++ top2) _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs @@ -365,13 +366,13 @@ genCall env target res args = do ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" ++ " 1, given " ++ show (length t) ++ "." let creg = ret_reg res - let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) - let allStmts = stmts `snocOL` s1 `appOL` stmts3 + vreg <- getCmmReg (CmmLocal creg) + let allStmts = stmts `snocOL` s1 if retTy == pLower (getVarType vreg) then do let s2 = Store v1 vreg - return (env3, allStmts `snocOL` s2 `appOL` retStmt, - top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `appOL` retStmt, + top1 ++ top2) else do let ty = pLower $ getVarType vreg let op = case ty of @@ -383,105 +384,83 @@ genCall env target res args = do (v2, s2) <- doExpr ty $ Cast op v1 ty let s3 = Store v2 vreg - return (env3, allStmts `snocOL` s2 `snocOL` s3 - `appOL` retStmt, top1 ++ top2 ++ top3) + return (allStmts `snocOL` s2 `snocOL` s3 + `appOL` retStmt, top1 ++ top2) -- genCallSimpleCast _ _ _ dsts _ = -- panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") -- | Create a function pointer from a target. -getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> ForeignTarget - -> UniqSM ExprData -getFunPtr env funTy targ = case targ of - ForeignTarget (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm env lbl +getFunPtr :: (LMString -> LlvmType) -> ForeignTarget + -> LlvmM ExprData +getFunPtr funTy targ = case targ of + ForeignTarget (CmmLit (CmmLabel lbl)) _ -> do + name <- strCLabel_llvm lbl + getHsFunc' name (funTy name) ForeignTarget expr _ -> do - (env', v1, stmts, top) <- exprToVar env expr + (v1, stmts, top) <- exprToVar expr + dflags <- getDynFlags let fty = funTy $ fsLit "dynamic" cast = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ showSDoc (getDflags env) (ppr ty) ++ ")" + ++ " call! (" ++ showSDoc dflags (ppr ty) ++ ")" (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (env', v2, stmts `snocOL` s1, top) - - PrimTarget mop -> litCase $ cmmPrimOpFunctions env mop - - where - litCase name = do - case funLookup name env of - Just ty'@(LMFunction sig) -> do - -- Function in module in right form - let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing Global - return (env, fun, nilOL, []) - - Just ty' -> do - -- label in module but not function pointer, convert - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name (pLift ty') (funcLinkage sig) - Nothing Nothing Global - (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (env, v1, unitOL s1, []) - - Nothing -> do - -- label not in module, create external reference - let fty@(LMFunction sig) = funTy name - fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing Global - top = [CmmData Data [([],[fty])]] - env' = funInsert name fty env - return (env', fun, nilOL, top) + return (v2, stmts `snocOL` s1, top) + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty -- | Conversion of call arguments. -arg_vars :: LlvmEnv - -> [(CmmActual, ForeignHint)] +arg_vars :: [(CmmActual, ForeignHint)] -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) - -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) -arg_vars env [] (vars, stmts, tops) - = return (env, vars, stmts, tops) +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) -arg_vars env ((e, AddrHint):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e +arg_vars ((e, AddrHint):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + dflags <- getDynFlags let op = case getVarType v1 of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr a -> panic $ "genCall: Can't cast llvmType to i8*! (" - ++ showSDoc (getDflags env) (ppr a) ++ ")" + ++ showSDoc dflags (ppr a) ++ ")" (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr - arg_vars env' rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, tops ++ top') -arg_vars env ((e, _):rest) (vars, stmts, tops) - = do (env', v1, stmts', top') <- exprToVar env e - arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') +arg_vars ((e, _):rest) (vars, stmts, tops) + = do (v1, stmts', top') <- exprToVar e + arg_vars rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') -- | Cast a collection of LLVM variables to specific types. -castVars :: DynFlags -> [(LlvmVar, LlvmType)] - -> UniqSM ([LlvmVar], LlvmStatements) -castVars dflags vars = do - done <- mapM (uncurry (castVar dflags)) vars +castVars :: [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars vars = do + done <- mapM (uncurry castVar) vars let (vars', stmts) = unzip done return (vars', toOL stmts) -- | Cast an LLVM variable to a specific type, panicing if it can't be done. -castVar :: DynFlags -> LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) -castVar dflags v t - | getVarType v == t +castVar :: LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar v t | getVarType v == t = return (v, Nop) | otherwise - = let op = case (getVarType v, t) of + = do dflags <- getDynFlags + let op = case (getVarType v, t) of (LMInt n, LMInt m) -> if n < m then LM_Sext else LM_Trunc (vt, _) | isFloat vt && isFloat t @@ -496,13 +475,23 @@ castVar dflags v t (vt, _) -> panic $ "castVars: Can't cast this type (" ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" - in doExpr t $ Cast op v t + doExpr t $ Cast op v t -- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString -cmmPrimOpFunctions env mop - = case mop of +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + ver <- getLlvmVer + dflags <- getDynFlags + let intrinTy1 = (if ver >= 28 + then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + intrinTy2 = (if ver >= 28 + then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" @@ -554,44 +543,36 @@ cmmPrimOpFunctions env mop MO_Touch -> unsupported MO_UF_Conv _ -> unsupported - where - dflags = getDflags env - intrinTy1 = (if getLlvmVer env >= 28 - then "p0i8.p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) - intrinTy2 = (if getLlvmVer env >= 28 - then "p0i8." else "") ++ showSDoc dflags (ppr $ llvmWord dflags) - unsupported = panic ("cmmPrimOpFunctions: " ++ show mop - ++ " not supported here") - -- | Tail function calls -genJump :: LlvmEnv -> CmmExpr -> [GlobalReg] -> UniqSM StmtData +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData -- Call to known function -genJump env (CmmLit (CmmLabel lbl)) live = do - (env', vf, stmts, top) <- getHsFunc env live lbl - (stgRegs, stgStmts) <- funEpilogue env live +genJump (CmmLit (CmmLabel lbl)) live = do + (vf, stmts, top) <- getHsFunc live lbl + (stgRegs, stgStmts) <- funEpilogue live let s1 = Expr $ Call TailCall vf stgRegs llvmStdFunAttrs let s2 = Return Nothing - return (env', stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + return (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) -- Call to unknown function / address -genJump env expr live = do - let fty = llvmFunTy (getDflags env) live - (env', vf, stmts, top) <- exprToVar env expr +genJump expr live = do + fty <- llvmFunTy live + (vf, stmts, top) <- exprToVar expr + dflags <- getDynFlags let cast = case getVarType vf of ty | isPointer ty -> LM_Bitcast ty | isInt ty -> LM_Inttoptr ty -> panic $ "genJump: Expr is of bad type for function call! (" - ++ showSDoc (getDflags env) (ppr ty) ++ ")" + ++ showSDoc dflags (ppr ty) ++ ")" (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) - (stgRegs, stgStmts) <- funEpilogue env live + (stgRegs, stgStmts) <- funEpilogue live let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs let s3 = Return Nothing - return (env', stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, top) @@ -599,81 +580,81 @@ genJump env expr live = do -- -- We use stack allocated variables for CmmReg. The optimiser will replace -- these with registers when possible. -genAssign :: LlvmEnv -> CmmReg -> CmmExpr -> UniqSM StmtData -genAssign env reg val = do - let dflags = getDflags env - (env1, vreg, stmts1, top1) = getCmmReg env reg - (env2, vval, stmts2, top2) <- exprToVar env1 val - let stmts = stmts1 `appOL` stmts2 +genAssign :: CmmReg -> CmmExpr -> LlvmM StmtData +genAssign reg val = do + vreg <- getCmmReg reg + (vval, stmts2, top2) <- exprToVar val + let stmts = stmts2 let ty = (pLower . getVarType) vreg + dflags <- getDynFlags case ty of -- Some registers are pointer types, so need to cast value to pointer LMPointer _ | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) LMVector _ _ -> do (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty let s2 = Store v vreg - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top2) _ -> do let s1 = Store vval vreg - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top2) -- | CmmStore operation -genStore :: LlvmEnv -> CmmExpr -> CmmExpr -> UniqSM StmtData +genStore :: CmmExpr -> CmmExpr -> LlvmM StmtData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genStore env addr@(CmmReg (CmmGlobal r)) val - = genStore_fast env addr r 0 val +genStore addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val -genStore env addr@(CmmRegOff (CmmGlobal r) n) val - = genStore_fast env addr r n val +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val -genStore env addr@(CmmMachOp (MO_Add _) [ +genStore addr@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (fromInteger n) val + = genStore_fast addr r (fromInteger n) val -genStore env addr@(CmmMachOp (MO_Sub _) [ +genStore addr@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) val - = genStore_fast env addr r (negate $ fromInteger n) val + = genStore_fast addr r (negate $ fromInteger n) val -- generic case -genStore env addr val = genStore_slow env addr val [other] +genStore addr val + = do other <- getTBAAMeta otherN + genStore_slow addr val other -- | CmmStore operation -- This is a special case for storing to a global register pointer -- offset such as I32[Sp+8]. -genStore_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmExpr - -> UniqSM StmtData -genStore_fast env addr r n val - = let dflags = getDflags env - gr = lmGlobalRegVar (getDflags env) r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genStore_fast :: CmmExpr -> GlobalReg -> Int -> CmmExpr + -> LlvmM StmtData +genStore_fast addr r n val + = do dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (env', vval, stmts, top) <- exprToVar env val - (gv, s1) <- doExpr grt $ Load gr + (vval, stmts, top) <- exprToVar val (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case pLower grt == getVarType vval of -- were fine True -> do let s3 = MetaStmt meta $ Store vval ptr - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3, top) -- cast to pointer type needed @@ -681,38 +662,39 @@ genStore_fast env addr r n val let ty = (pLift . getVarType) vval (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty let s4 = MetaStmt meta $ Store vval ptr' - return (env', stmts `snocOL` s1 `snocOL` s2 + return (stmts `appOL` s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, top) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genStore_slow env addr val meta + False -> genStore_slow addr val meta -- | CmmStore operation -- Generic case. Uses casts and pointer arithmetic if needed. -genStore_slow :: LlvmEnv -> CmmExpr -> CmmExpr -> [MetaAnnot] -> UniqSM StmtData -genStore_slow env addr val meta = do - (env1, vaddr, stmts1, top1) <- exprToVar env addr - (env2, vval, stmts2, top2) <- exprToVar env1 val +genStore_slow :: CmmExpr -> CmmExpr -> [MetaAnnot] -> LlvmM StmtData +genStore_slow addr val meta = do + (vaddr, stmts1, top1) <- exprToVar addr + (vval, stmts2, top2) <- exprToVar val let stmts = stmts1 `appOL` stmts2 + dflags <- getDynFlags case getVarType vaddr of -- sometimes we need to cast an int to a pointer before storing LMPointer ty@(LMPointer _) | getVarType vval == llvmWord dflags -> do (v, s1) <- doExpr ty $ Cast LM_Inttoptr vval ty let s2 = MetaStmt meta $ Store v vaddr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) LMPointer _ -> do let s1 = MetaStmt meta $ Store vval vaddr - return (env2, stmts `snocOL` s1, top1 ++ top2) + return (stmts `snocOL` s1, top1 ++ top2) i@(LMInt _) | i == llvmWord dflags -> do let vty = pLift $ getVarType vval (vptr, s1) <- doExpr vty $ Cast LM_Inttoptr vaddr vty let s2 = MetaStmt meta $ Store vval vptr - return (env2, stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + return (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) other -> pprPanic "genStore: ptr not right type!" @@ -720,29 +702,28 @@ genStore_slow env addr val meta = do "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ showSDoc dflags (ppr vaddr))) - where dflags = getDflags env -- | Unconditional branch -genBranch :: LlvmEnv -> BlockId -> UniqSM StmtData -genBranch env id = +genBranch :: BlockId -> LlvmM StmtData +genBranch id = let label = blockIdToLlvm id - in return (env, unitOL $ Branch label, []) + in return (unitOL $ Branch label, []) -- | Conditional branch -genCondBranch :: LlvmEnv -> CmmExpr -> BlockId -> BlockId -> UniqSM StmtData -genCondBranch env cond idT idF = do +genCondBranch :: CmmExpr -> BlockId -> BlockId -> LlvmM StmtData +genCondBranch cond idT idF = do let labelT = blockIdToLlvm idT let labelF = blockIdToLlvm idF -- See Note [Literals and branch conditions]. - (env', vc, stmts, top) <- exprToVarOpt env i1Option cond + (vc, stmts, top) <- exprToVarOpt i1Option cond if getVarType vc == i1 then do let s1 = BranchIf vc labelT labelF - return $ (env', stmts `snocOL` s1, top) + return (stmts `snocOL` s1, top) else do - let dflags = getDflags env + dflags <- getDynFlags panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" {- Note [Literals and branch conditions] @@ -801,9 +782,9 @@ For a real example of this, see ./rts/StgStdThunks.cmm -- -- N.B. We remove Nothing's from the list of branches, as they are 'undefined'. -- However, they may be defined one day, so we better document this behaviour. -genSwitch :: LlvmEnv -> CmmExpr -> [Maybe BlockId] -> UniqSM StmtData -genSwitch env cond maybe_ids = do - (env', vc, stmts, top) <- exprToVar env cond +genSwitch :: CmmExpr -> [Maybe BlockId] -> LlvmM StmtData +genSwitch cond maybe_ids = do + (vc, stmts, top) <- exprToVar cond let ty = getVarType vc let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] @@ -812,7 +793,7 @@ genSwitch env cond maybe_ids = do let (_, defLbl) = head labels let s1 = Switch vc defLbl labels - return $ (env', stmts `snocOL` s1, top) + return $ (stmts `snocOL` s1, top) -- ----------------------------------------------------------------------------- @@ -820,11 +801,10 @@ genSwitch env cond maybe_ids = do -- -- | An expression conversion return data: --- * LlvmEnv: The new enviornment -- * LlvmVar: The var holding the result of the expression -- * LlvmStatements: Any statements needed to evaluate the expression -- * LlvmCmmDecl: Any global data needed for this expression -type ExprData = (LlvmEnv, LlvmVar, LlvmStatements, [LlvmCmmDecl]) +type ExprData = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) -- | Values which can be passed to 'exprToVar' to configure its -- behaviour in certain circumstances. @@ -844,47 +824,47 @@ wordOption = EOption False -- | Convert a CmmExpr to a list of LlvmStatements with the result of the -- expression being stored in the returned LlvmVar. -exprToVar :: LlvmEnv -> CmmExpr -> UniqSM ExprData -exprToVar env = exprToVarOpt env wordOption +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption -exprToVarOpt :: LlvmEnv -> EOption -> CmmExpr -> UniqSM ExprData -exprToVarOpt env opt e = case e of +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of CmmLit lit - -> genLit opt env lit + -> genLit opt lit CmmLoad e' ty - -> genLoad env e' ty + -> genLoad e' ty -- Cmmreg in expression is the value, so must load. If you want actual -- reg pointer, call getCmmReg directly. CmmReg r -> do - let (env', vreg, stmts, top) = getCmmReg env r - (v1, s1) <- doExpr (pLower $ getVarType vreg) $ Load vreg - case (isPointer . getVarType) v1 of + (v1, ty, s1) <- getCmmRegVal r + case isPointer ty of True -> do -- Cmm wants the value, so pointer types must be cast to ints + dflags <- getDynFlags (v2, s2) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint v1 (llvmWord dflags) - return (env', v2, stmts `snocOL` s1 `snocOL` s2, top) + return (v2, s1 `snocOL` s2, []) - False -> return (env', v1, stmts `snocOL` s1, top) + False -> return (v1, s1, []) CmmMachOp op exprs - -> genMachOp env opt op exprs + -> genMachOp opt op exprs CmmRegOff r i - -> exprToVar env $ expandCmmReg dflags (r, i) + -> do dflags <- getDynFlags + exprToVar $ expandCmmReg dflags (r, i) CmmStackSlot _ _ -> panic "exprToVar: CmmStackSlot not supported!" - where dflags = getDflags env -- | Handle CmmMachOp expressions -genMachOp :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Unary Machop -genMachOp env _ op [x] = case op of +genMachOp _ op [x] = case op of MO_Not w -> let all1 = mkIntLit (widthToLlvmInt w) (-1) @@ -984,29 +964,28 @@ genMachOp env _ op [x] = case op of MO_VF_Quot _ _ -> panicOp where - dflags = getDflags env - negate ty v2 negOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) negateVec ty v2 negOp = do - (env', vx, stmts1, top) <- exprToVar env x - ([vx'], stmts2) <- castVars dflags [(vx, ty)] + (vx, stmts1, top) <- exprToVar x + ([vx'], stmts2) <- castVars [(vx, ty)] (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' - return (env', v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) fiConv ty convOp = do - (env', vx, stmts, top) <- exprToVar env x + (vx, stmts, top) <- exprToVar x (v1, s1) <- doExpr ty $ Cast convOp vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) sameConv from ty reduce expand = do - x'@(env', vx, stmts, top) <- exprToVar env x + x'@(vx, stmts, top) <- exprToVar x let sameConv' op = do (v1, s1) <- doExpr ty $ Cast op vx ty - return (env', v1, stmts `snocOL` s1, top) + return (v1, stmts `snocOL` s1, top) + dflags <- getDynFlags let toWidth = llvmWidthInBits dflags ty -- LLVM doesn't like trying to convert to same width, so -- need to check for that as we do get Cmm code doing it. @@ -1019,88 +998,82 @@ genMachOp env _ op [x] = case op of ++ "with one argument! (" ++ show op ++ ")" -- Handle GlobalRegs pointers -genMachOp env opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast env opt o r (fromInteger n) e +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (fromInteger n) e -genMachOp env opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] - = genMachOp_fast env opt o r (negate . fromInteger $ n) e +genMachOp opt o@(MO_Sub _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (negate . fromInteger $ n) e -- Generic case -genMachOp env opt op e = genMachOp_slow env opt op e +genMachOp opt op e = genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This is a specialised method that handles Global register manipulations like -- 'Sp - 16', using the getelementptr instruction. -genMachOp_fast :: LlvmEnv -> EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] - -> UniqSM ExprData -genMachOp_fast env opt op r n e - = let dflags = getDflags env - gr = lmGlobalRegVar dflags r - grt = (pLower . getVarType) gr - (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of +genMachOp_fast :: EOption -> MachOp -> GlobalReg -> Int -> [CmmExpr] + -> LlvmM ExprData +genMachOp_fast opt op r n e + = do (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + dflags <- getDynFlags + let (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, []) + return (var, s1 `snocOL` s2 `snocOL` s3, []) - False -> genMachOp_slow env opt op e + False -> genMachOp_slow opt op e -- | Handle CmmMachOp expressions -- This handles all the cases not handle by the specialised genMachOp_fast. -genMachOp_slow :: LlvmEnv -> EOption -> MachOp -> [CmmExpr] -> UniqSM ExprData +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData -- Element extraction -genMachOp_slow env _ (MO_V_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmInt w -genMachOp_slow env _ (MO_VF_Extract l w) [val, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, vidx, stmts2, top2) <- exprToVar env1 idx - ([vval'], stmts3) <- castVars dflags [(vval, LMVector l ty)] - (v1, s1) <- doExpr ty $ Extract vval' vidx - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = do + (vval, stmts1, top1) <- exprToVar val + (vidx, stmts2, top2) <- exprToVar idx + ([vval'], stmts3) <- castVars [(vval, LMVector l ty)] + (v1, s1) <- doExpr ty $ Extract vval' vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) where - dflags = getDflags env ty = widthToLlvmFloat w -- Element insertion -genMachOp_slow env _ (MO_V_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmInt w) -genMachOp_slow env _ (MO_VF_Insert l w) [val, elt, idx] = do - (env1, vval, stmts1, top1) <- exprToVar env val - (env2, velt, stmts2, top2) <- exprToVar env1 elt - (env3, vidx, stmts3, top3) <- exprToVar env2 idx - ([vval'], stmts4) <- castVars dflags [(vval, ty)] - (v1, s1) <- doExpr ty $ Insert vval' velt vidx - return (env3, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = do + (vval, stmts1, top1) <- exprToVar val + (velt, stmts2, top2) <- exprToVar elt + (vidx, stmts3, top3) <- exprToVar idx + ([vval'], stmts4) <- castVars [(vval, ty)] + (v1, s1) <- doExpr ty $ Insert vval' velt vidx + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `appOL` stmts4 `snocOL` s1, top1 ++ top2 ++ top3) where - dflags = getDflags env ty = LMVector l (widthToLlvmFloat w) -- Binary MachOp -genMachOp_slow env opt op [x, y] = case op of +genMachOp_slow opt op [x, y] = case op of MO_Eq _ -> genBinComp opt LM_CMP_Eq MO_Ne _ -> genBinComp opt LM_CMP_Ne @@ -1181,21 +1154,19 @@ genMachOp_slow env opt op [x, y] = case op of MO_VF_Neg {} -> panicOp where - dflags = getDflags env - binLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y if getVarType vx == getVarType vy then do (v1, s1) <- doExpr (ty vx) $ binOp vx vy - return (env2, v1, stmts1 `appOL` stmts2 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) else do -- Error. Continue anyway so we can debug the generated ll file. - let dflags = getDflags env - style = mkCodeStyle CStyle + dflags <- getDynFlags + let style = mkCodeStyle CStyle toString doc = renderWithStyle dflags doc style cmmToStr = (lines . toString . PprCmm.pprExpr) let dx = Comment $ map fsLit $ cmmToStr x @@ -1203,28 +1174,29 @@ genMachOp_slow env opt op [x, y] = case op of (v1, s1) <- doExpr (ty vx) $ binOp vx vy let allStmts = stmts1 `appOL` stmts2 `snocOL` dx `snocOL` dy `snocOL` s1 - return (env2, v1, allStmts, top1 ++ top2) + return (v1, allStmts, top1 ++ top2) binCastLlvmOp ty binOp = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y - ([vx', vy'], stmts3) <- castVars dflags [(vx, ty), (vy, ty)] + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + ([vx', vy'], stmts3) <- castVars [(vx, ty), (vy, ty)] (v1, s1) <- doExpr ty $ binOp vx' vy' - return (env2, v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, + return (v1, stmts1 `appOL` stmts2 `appOL` stmts3 `snocOL` s1, top1 ++ top2) -- | Need to use EOption here as Cmm expects word size results from -- comparisons while LLVM return i1. Need to extend to llvmWord type -- if expected. See Note [Literals and branch conditions]. genBinComp opt cmp = do - ed@(env', v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + ed@(v1, stmts, top) <- binLlvmOp (\_ -> i1) (Compare cmp) + dflags <- getDynFlags if getVarType v1 == i1 then case i1Expected opt of True -> return ed False -> do let w_ = llvmWord dflags (v2, s1) <- doExpr w_ $ Cast LM_Zext v1 w_ - return (env', v2, stmts `snocOL` s1, top) + return (v2, stmts `snocOL` s1, top) else panic $ "genBinComp: Compare returned type other then i1! " ++ (showSDoc dflags $ ppr $ getVarType v1) @@ -1237,11 +1209,12 @@ genMachOp_slow env opt op [x, y] = case op of -- CmmExpr's. This is the LLVM assembly equivalent of the NCG -- implementation. Its much longer due to type information/safety. -- This should actually compile to only about 3 asm instructions. - isSMulOK :: Width -> CmmExpr -> CmmExpr -> UniqSM ExprData + isSMulOK :: Width -> CmmExpr -> CmmExpr -> LlvmM ExprData isSMulOK _ x y = do - (env1, vx, stmts1, top1) <- exprToVar env x - (env2, vy, stmts2, top2) <- exprToVar env1 y + (vx, stmts1, top1) <- exprToVar x + (vy, stmts2, top2) <- exprToVar y + dflags <- getDynFlags let word = getVarType vx let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) let shift = llvmWidthInBits dflags word @@ -1260,7 +1233,7 @@ genMachOp_slow env opt op [x, y] = case op of (dst, s8) <- doExpr word $ LlvmOp LM_MO_Sub rlow2 rhigh2 let stmts = (unitOL s1) `snocOL` s2 `snocOL` s3 `snocOL` s4 `snocOL` s5 `snocOL` s6 `snocOL` s7 `snocOL` s8 - return (env2, dst, stmts1 `appOL` stmts2 `appOL` stmts, + return (dst, stmts1 `appOL` stmts2 `appOL` stmts, top1 ++ top2) else @@ -1270,59 +1243,59 @@ genMachOp_slow env opt op [x, y] = case op of ++ "with two arguments! (" ++ show op ++ ")" -- More then two expression, invalid! -genMachOp_slow _ _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" +genMachOp_slow _ _ _ = panic "genMachOp: More then 2 expressions in MachOp!" -- | Handle CmmLoad expression. -genLoad :: LlvmEnv -> CmmExpr -> CmmType -> UniqSM ExprData +genLoad :: CmmExpr -> CmmType -> LlvmM ExprData -- First we try to detect a few common cases and produce better code for -- these then the default case. We are mostly trying to detect Cmm code -- like I32[Sp + n] and use 'getelementptr' operations instead of the -- generic case that uses casts and pointer arithmetic -genLoad env e@(CmmReg (CmmGlobal r)) ty - = genLoad_fast env e r 0 ty +genLoad e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast e r 0 ty -genLoad env e@(CmmRegOff (CmmGlobal r) n) ty - = genLoad_fast env e r n ty +genLoad e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast e r n ty -genLoad env e@(CmmMachOp (MO_Add _) [ +genLoad e@(CmmMachOp (MO_Add _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (fromInteger n) ty + = genLoad_fast e r (fromInteger n) ty -genLoad env e@(CmmMachOp (MO_Sub _) [ +genLoad e@(CmmMachOp (MO_Sub _) [ (CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))]) ty - = genLoad_fast env e r (negate $ fromInteger n) ty + = genLoad_fast e r (negate $ fromInteger n) ty -- generic case -genLoad env e ty = genLoad_slow env e ty [other] +genLoad e ty + = do other <- getTBAAMeta otherN + genLoad_slow e ty other -- | Handle CmmLoad expression. -- This is a special case for loading from a global register pointer -- offset such as I32[Sp+8]. -genLoad_fast :: LlvmEnv -> CmmExpr -> GlobalReg -> Int -> CmmType - -> UniqSM ExprData -genLoad_fast env e r n ty = - let dflags = getDflags env - gr = lmGlobalRegVar dflags r - meta = [getTBAA r] - grt = (pLower . getVarType) gr - ty' = cmmToLlvmType ty +genLoad_fast :: CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast e r n ty = do + dflags <- getDynFlags + (gv, grt, s1) <- getCmmRegVal (CmmGlobal r) + meta <- getTBAARegMeta r + let ty' = cmmToLlvmType ty (ix,rem) = n `divMod` ((llvmWidthInBits dflags . pLower) grt `div` 8) - in case isPointer grt && rem == 0 of + case isPointer grt && rem == 0 of True -> do - (gv, s1) <- doExpr grt $ Load gr (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] -- We might need a different pointer type, so check case grt == ty' of -- were fine True -> do (var, s3) <- doExpr ty' (MExpr meta $ Load ptr) - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3, + return (var, s1 `snocOL` s2 `snocOL` s3, []) -- cast to pointer type needed @@ -1330,57 +1303,81 @@ genLoad_fast env e r n ty = let pty = pLift ty' (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty (var, s4) <- doExpr ty' (MExpr meta $ Load ptr') - return (env, var, unitOL s1 `snocOL` s2 `snocOL` s3 + return (var, s1 `snocOL` s2 `snocOL` s3 `snocOL` s4, []) -- If its a bit type then we use the slow method since -- we can't avoid casting anyway. - False -> genLoad_slow env e ty meta + False -> genLoad_slow e ty meta -- | Handle Cmm load expression. -- Generic case. Uses casts and pointer arithmetic if needed. -genLoad_slow :: LlvmEnv -> CmmExpr -> CmmType -> [MetaAnnot] -> UniqSM ExprData -genLoad_slow env e ty meta = do - (env', iptr, stmts, tops) <- exprToVar env e +genLoad_slow :: CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow e ty meta = do + (iptr, stmts, tops) <- exprToVar e + dflags <- getDynFlags case getVarType iptr of LMPointer _ -> do (dvar, load) <- doExpr (cmmToLlvmType ty) (MExpr meta $ Load iptr) - return (env', dvar, stmts `snocOL` load, tops) + return (dvar, stmts `snocOL` load, tops) i@(LMInt _) | i == llvmWord dflags -> do let pty = LMPointer $ cmmToLlvmType ty (ptr, cast) <- doExpr pty $ Cast LM_Inttoptr iptr pty (dvar, load) <- doExpr (cmmToLlvmType ty) (MExpr meta $ Load ptr) - return (env', dvar, stmts `snocOL` cast `snocOL` load, tops) + return (dvar, stmts `snocOL` cast `snocOL` load, tops) - other -> pprPanic "exprToVar: CmmLoad expression is not right type!" + other -> do dflags <- getDynFlags + pprPanic "exprToVar: CmmLoad expression is not right type!" (PprCmm.pprExpr e <+> text ( "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ ", Var: " ++ showSDoc dflags (ppr iptr))) - where dflags = getDflags env --- | Handle CmmReg expression --- --- We allocate CmmReg on the stack. This avoids having to map a CmmReg to an --- equivalent SSA form and avoids having to deal with Phi node insertion. --- This is also the approach recommended by LLVM developers. -getCmmReg :: LlvmEnv -> CmmReg -> ExprData -getCmmReg env r@(CmmLocal (LocalReg un _)) - = let exists = varLookup un env - (newv, stmts) = allocReg r - nenv = varInsert un (pLower $ getVarType newv) env - in case exists of - Just ety -> (env, (LMLocalVar un $ pLift ety), nilOL, []) - Nothing -> (nenv, newv, stmts, []) - -getCmmReg env (CmmGlobal g) = (env, lmGlobalRegVar (getDflags env) g, nilOL, []) - - --- | Allocate a CmmReg on the stack + +-- | Handle CmmReg expression. This will return a pointer to the stack +-- location of the register. Throws an error if it isn't allocated on +-- the stack. +getCmmReg :: CmmReg -> LlvmM LlvmVar +getCmmReg (CmmLocal (LocalReg un _)) + = do exists <- varLookup un + dflags <- getDynFlags + case exists of + Just ety -> return (LMLocalVar un $ pLift ety) + Nothing -> fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr un) ++ " was not allocated!" + -- This should never happen, as every local variable should + -- have been assigned a value at some point, triggering + -- "funPrologue" to allocate it on the stack. + +getCmmReg (CmmGlobal g) + = do onStack <- checkStackReg g + dflags <- getDynFlags + if onStack + then return (lmGlobalRegVar dflags g) + else fail $ "getCmmReg: Cmm register " ++ showSDoc dflags (ppr g) ++ " not stack-allocated!" + +-- | Return the value of a given register, as well as its type. Might +-- need to be load from stack. +getCmmRegVal :: CmmReg -> LlvmM (LlvmVar, LlvmType, LlvmStatements) +getCmmRegVal reg = + case reg of + CmmGlobal g -> do + onStack <- checkStackReg g + dflags <- getDynFlags + if onStack then loadFromStack else do + let r = lmGlobalRegArg dflags g + return (r, getVarType r, nilOL) + _ -> loadFromStack + where loadFromStack = do + ptr <- getCmmReg reg + let ty = pLower $ getVarType ptr + (v, s) <- doExpr ty (Load ptr) + return (v, ty, unitOL s) + +-- | Allocate a local CmmReg on the stack allocReg :: CmmReg -> (LlvmVar, LlvmStatements) allocReg (CmmLocal (LocalReg un ty)) = let ty' = cmmToLlvmType ty @@ -1393,8 +1390,8 @@ allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" -- | Generate code for a literal -genLit :: EOption -> LlvmEnv -> CmmLit -> UniqSM ExprData -genLit opt env (CmmInt i w) +genLit :: EOption -> CmmLit -> LlvmM ExprData +genLit opt (CmmInt i w) -- See Note [Literals and branch conditions]. = let width | i1Expected opt = i1 | otherwise = LMInt (widthInBits w) @@ -1402,56 +1399,41 @@ genLit opt env (CmmInt i w) -- , fsLit $ "Width : " ++ show w -- , fsLit $ "Width' : " ++ show (widthInBits w) -- ] - in return (env, mkIntLit width i, nilOL, []) + in return (mkIntLit width i, nilOL, []) -genLit _ env (CmmFloat r w) - = return (env, LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), nilOL, []) - -genLit opt env (CmmVec ls) + +genLit opt (CmmVec ls) = do llvmLits <- mapM toLlvmLit ls - return (env, LMLitVar $ LMVectorLit llvmLits, nilOL, []) + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) where - toLlvmLit :: CmmLit -> UniqSM LlvmLit + toLlvmLit :: CmmLit -> LlvmM LlvmLit toLlvmLit lit = do - (_, llvmLitVar, _, _) <- genLit opt env lit + (llvmLitVar, _, _) <- genLit opt lit case llvmLitVar of LMLitVar llvmLit -> return llvmLit _ -> panic "genLit" -genLit _ env cmm@(CmmLabel l) - = let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label definition and then pointer to it - Nothing -> do - let glob@(LMGlobal var _) = genStringLabelRef dflags label - let ldata = [CmmData Data [([glob], [])]] - let env' = funInsert label (pLower $ getVarType var) env - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env', v1, unitOL s1, ldata) - - -- Referenced data exists in this module, retrieve type and make - -- pointer to it. - Just ty' -> do - let var = LMGlobalVar label (LMPointer ty') - ExternallyVisible Nothing Nothing Global - (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) - return (env, v1, unitOL s1, []) - -genLit opt env (CmmLabelOff label off) = do - let dflags = getDflags env - (env', vlbl, stmts, stat) <- genLit opt env (CmmLabel label) +genLit _ cmm@(CmmLabel l) + = do var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let lmty = cmmToLlvmType $ cmmLitType dflags cmm + (v1, s1) <- doExpr lmty $ Cast LM_Ptrtoint var (llvmWord dflags) + return (v1, unitOL s1, []) + +genLit opt (CmmLabelOff label off) = do + dflags <- getDynFlags + (vlbl, stmts, stat) <- genLit opt (CmmLabel label) let voff = toIWord dflags off (v1, s1) <- doExpr (getVarType vlbl) $ LlvmOp LM_MO_Add vlbl voff - return (env', v1, stmts `snocOL` s1, stat) + return (v1, stmts `snocOL` s1, stat) -genLit opt env (CmmLabelDiffOff l1 l2 off) = do - let dflags = getDflags env - (env1, vl1, stmts1, stat1) <- genLit opt env (CmmLabel l1) - (env2, vl2, stmts2, stat2) <- genLit opt env1 (CmmLabel l2) +genLit opt (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + (vl1, stmts1, stat1) <- genLit opt (CmmLabel l1) + (vl2, stmts2, stat2) <- genLit opt (CmmLabel l2) let voff = toIWord dflags off let ty1 = getVarType vl1 let ty2 = getVarType vl2 @@ -1461,16 +1443,16 @@ genLit opt env (CmmLabelDiffOff l1 l2 off) = do then do (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff - return (env2, v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, + return (v2, stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2, stat1 ++ stat2) else panic "genLit: CmmLabelDiffOff encountered with different label ty!" -genLit opt env (CmmBlock b) - = genLit opt env (CmmLabel $ infoTblLbl b) +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) -genLit _ _ CmmHighStackMark +genLit _ CmmHighStackMark = panic "genStaticLit - CmmHighStackMark unsupported!" @@ -1478,51 +1460,82 @@ genLit _ _ CmmHighStackMark -- * Misc -- --- | Function prologue. Load STG arguments into variables for function. -funPrologue :: DynFlags -> LiveGlobalRegs -> [LlvmStatement] -funPrologue dflags live = concat $ map getReg $ activeStgRegs platform - where platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - getReg rr = - let reg = lmGlobalRegVar dflags rr - arg = lmGlobalRegArg dflags rr - ty = (pLower . getVarType) reg - trash = LMLitVar $ LMUndefLit ty - alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 - in - if isLive rr - then [alloc, Store arg reg] - else [alloc, Store trash reg] - +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allcoated on the +-- stack. This avoids having to map a CmmReg to an equivalent SSA form +-- and avoids having to deal with Phi node insertion. This is also +-- the approach recommended by LLVM developers. +-- +-- On the other hand, this is unecessarily verbose if the register in +-- question is never written. Therefore we skip it where we can to +-- save a few lines in the output and hopefully speed compilation up a +-- bit. +funPrologue :: LiveGlobalRegs -> [CmmBlock] -> LlvmM StmtData +funPrologue live cmmBlocks = do + + trash <- getTrashRegs + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + -- Calls will trash all registers. Unfortunately, this needs them to + -- be stack-allocated in the first place. + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = map CmmGlobal trash ++ map CmmLocal rs + getAssignedRegs _ = [] + getRegsBlock (_, body, _) = concatMap getAssignedRegs $ blockToList body + assignedRegs = nub $ concatMap (getRegsBlock . blockSplit) cmmBlocks + isLive r = r `elem` alwaysLive || r `elem` live + + dflags <- getDynFlags + stmtss <- flip mapM assignedRegs $ \reg -> + case reg of + CmmLocal (LocalReg un _) -> do + let (newv, stmts) = allocReg reg + varInsert un (pLower $ getVarType newv) + return stmts + CmmGlobal r -> do + let reg = lmGlobalRegVar dflags r + arg = lmGlobalRegArg dflags r + ty = (pLower . getVarType) reg + trash = LMLitVar $ LMUndefLit ty + rval = if isLive r then arg else trash + alloc = Assignment reg $ Alloca (pLower $ getVarType reg) 1 + markStackReg r + return $ toOL [alloc, Store rval reg] + + return (concatOL stmtss, []) -- | Function epilogue. Load STG variables to use as argument for call. -- STG Liveness optimisation done here. -funEpilogue :: LlvmEnv -> LiveGlobalRegs -> UniqSM ([LlvmVar], LlvmStatements) +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + + -- Have information and liveness optimisation is enabled? + let liveRegs = alwaysLive ++ live + isSSE (FloatReg _) = True + isSSE (DoubleReg _) = True + isSSE (XmmReg _) = True + isSSE _ = False + + -- Set to value or "undef" depending on whether the register is + -- actually live + dflags <- getDynFlags + let loadExpr r = do + (v, _, s) <- getCmmRegVal (CmmGlobal r) + return (Just $ v, s) + loadUndef r = do + let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) + return (Just $ LMLitVar $ LMUndefLit ty, nilOL) + platform <- getDynFlag targetPlatform + loads <- flip mapM (activeStgRegs platform) $ \r -> case () of + _ | r `elem` liveRegs -> loadExpr r + | not (isSSE r) -> loadUndef r + | otherwise -> return (Nothing, nilOL) --- Have information and liveness optimisation is enabled -funEpilogue env live = do - loads <- mapM loadExpr (filter isPassed (activeStgRegs platform)) let (vars, stmts) = unzip loads - return (vars, concatOL stmts) - where - dflags = getDflags env - platform = targetPlatform dflags - isLive r = r `elem` alwaysLive || r `elem` live - isPassed r = not (isSSE r) || isLive r - isSSE (FloatReg _) = True - isSSE (DoubleReg _) = True - isSSE (XmmReg _) = True - isSSE _ = False - loadExpr r | isLive r = do - let reg = lmGlobalRegVar dflags r - (v,s) <- doExpr (pLower $ getVarType reg) $ Load reg - return (v, unitOL s) - loadExpr r = do - let ty = (pLower . getVarType $ lmGlobalRegVar dflags r) - return (LMLitVar $ LMUndefLit ty, unitOL Nop) - - --- | A serries of statements to trash all the STG registers. + return (catMaybes vars, concatOL stmts) + + +-- | A series of statements to trash all the STG registers. -- -- In LLVM we pass the STG registers around everywhere in function calls. -- So this means LLVM considers them live across the entire function, when @@ -1533,59 +1546,47 @@ funEpilogue env live = do -- before the call by assigning the 'undef' value to them. The ones we -- need are restored from the Cmm local var and the ones we don't need -- are fine to be trashed. -trashStmts :: DynFlags -> LlvmStatements -trashStmts dflags = concatOL $ map trashReg $ activeStgRegs platform - where platform = targetPlatform dflags - trashReg r = - let reg = lmGlobalRegVar dflags r - ty = (pLower . getVarType) reg - trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg - in case callerSaves (targetPlatform dflags) r of - True -> trash - False -> nilOL - +getTrashStmts :: LlvmM LlvmStatements +getTrashStmts = do + regs <- getTrashRegs + stmts <- flip mapM regs $ \ r -> do + reg <- getCmmReg (CmmGlobal r) + let ty = (pLower . getVarType) reg + return $ Store (LMLitVar $ LMUndefLit ty) reg + return $ toOL stmts + +getTrashRegs :: LlvmM [GlobalReg] +getTrashRegs = do plat <- getLlvmPlatform + return $ filter (callerSaves plat) (activeStgRegs plat) -- | Get a function pointer to the CLabel specified. -- -- This is for Haskell functions, function type is assumed, so doesn't work -- with foreign functions. -getHsFunc :: LlvmEnv -> LiveGlobalRegs -> CLabel -> UniqSM ExprData -getHsFunc env live lbl - = let dflags = getDflags env - fn = strCLabel_llvm env lbl - ty = funLookup fn env - in case ty of - -- Function in module in right form - Just ty'@(LMFunction sig) -> do - let fun = LMGlobalVar fn ty' (funcLinkage sig) Nothing Nothing Global - return (env, fun, nilOL, []) - - -- label in module but not function pointer, convert - Just ty' -> do - let fun = LMGlobalVar fn (pLift ty') ExternallyVisible - Nothing Nothing Global - (v1, s1) <- doExpr (pLift (llvmFunTy dflags live)) $ - Cast LM_Bitcast fun (pLift (llvmFunTy dflags live)) - return (env, v1, unitOL s1, []) - - -- label not in module, create external reference - Nothing -> do - let ty' = LMFunction $ llvmFunSig env live lbl ExternallyVisible - let fun = LMGlobalVar fn ty' ExternallyVisible Nothing Nothing Global - let top = CmmData Data [([],[ty'])] - let env' = funInsert fn ty' env - return (env', fun, nilOL, [top]) - +getHsFunc :: LiveGlobalRegs -> CLabel -> LlvmM ExprData +getHsFunc live lbl + = do fty <- llvmFunTy live + name <- strCLabel_llvm lbl + getHsFunc' name fty + +getHsFunc' :: LMString -> LlvmType -> LlvmM ExprData +getHsFunc' name fty + = do fun <- getGlobalPtr name + if getVarType fun == fty + then return (fun, nilOL, []) + else do (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (v1, unitOL s1, []) -- | Create a new local var -mkLocalVar :: LlvmType -> UniqSM LlvmVar +mkLocalVar :: LlvmType -> LlvmM LlvmVar mkLocalVar ty = do - un <- getUniqueUs + un <- runUs getUniqueUs return $ LMLocalVar un ty -- | Execute an expression, assigning result to a var -doExpr :: LlvmType -> LlvmExpression -> UniqSM (LlvmVar, LlvmStatement) +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) doExpr ty expr = do v <- mkLocalVar ty return (v, Assignment v expr) @@ -1622,3 +1623,13 @@ panic s = Outputable.panic $ "LlvmCodeGen.CodeGen." ++ s pprPanic :: String -> SDoc -> a pprPanic s d = Outputable.pprPanic ("LlvmCodeGen.CodeGen." ++ s) d + +-- | Returns TBAA meta data by unique +getTBAAMeta :: Unique -> LlvmM [MetaAnnot] +getTBAAMeta u = do + mi <- getUniqMeta u + return [MetaAnnot tbaa (MetaNode i) | let Just i = mi] + +-- | Returns TBAA meta data for given register +getTBAARegMeta :: GlobalReg -> LlvmM [MetaAnnot] +getTBAARegMeta = getTBAAMeta . getTBAA diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index f31b3e5203b8..6212cfc9fbf6 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -3,7 +3,7 @@ -- module LlvmCodeGen.Data ( - genLlvmData, resolveLlvmDatas, resolveLlvmData + genLlvmData ) where #include "HsVersions.h" @@ -18,8 +18,6 @@ import Cmm import FastString import qualified Outputable -import Data.List (foldl') - -- ---------------------------------------------------------------------------- -- * Constants -- @@ -32,43 +30,23 @@ structStr = fsLit "_struct" -- * Top level -- --- | Pass a CmmStatic section to an equivalent Llvm code. Can't --- complete this completely though as we need to pass all CmmStatic --- sections before all references can be resolved. This last step is --- done by 'resolveLlvmData'. -genLlvmData :: LlvmEnv -> (Section, CmmStatics) -> LlvmUnresData -genLlvmData env (sec, Statics lbl xs) = - let dflags = getDflags env - static = map genData xs - label = strCLabel_llvm env lbl - - types = map getStatTypes static - getStatTypes (Left x) = cmmToLlvmType $ cmmLitType dflags x - getStatTypes (Right x) = getStatType x +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, CmmStatics) -> LlvmM LlvmData +genLlvmData (sec, Statics lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + let types = map getStatType static strucTy = LMStruct types alias = LMAlias ((label `appendFS` structStr), strucTy) - in (lbl, sec, alias, static) - -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 ([], []) struct = Just $ LMStaticStruc static alias - label = strCLabel_llvm env lbl link = if (externallyVisibleCLabel lbl) then ExternallyVisible else Internal const = if isSecConstant sec then Constant else Global glob = LMGlobalVar label alias link Nothing Nothing const - in (env', ((LMGlobal glob struct):refs, [alias])) + + return ([LMGlobal glob struct], [alias]) -- | Should a data in this section be considered constant isSecConstant :: Section -> Bool @@ -81,81 +59,20 @@ isSecConstant UninitialisedData = False isSecConstant (OtherSection _) = False --- ---------------------------------------------------------------------------- --- ** Resolve Data/CLabel references --- - --- | Resolve data list -resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [LMGlobal]) - -> (LlvmEnv, [LlvmStatic], [LMGlobal]) - -resDatas env [] (stats, glob) - = (env, stats, glob) - -resDatas env (cmm:rest) (stats, globs) - = let (env', nstat, nglob) = resData env cmm - in resDatas env' rest (stats ++ [nstat], globs ++ nglob) - --- | Resolve an individual static label if it needs to be. --- --- We check the 'LlvmEnv' to see if the reference has been defined in this --- 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, [LMGlobal]) - -resData env (Right stat) = (env, stat, []) - -resData env (Left cmm@(CmmLabel l)) = - let dflags = getDflags env - label = strCLabel_llvm env l - ty = funLookup label env - lmty = cmmToLlvmType $ cmmLitType dflags cmm - in case ty of - -- Make generic external label defenition and then pointer to it - Nothing -> - let glob@(LMGlobal var _) = genStringLabelRef dflags label - env' = funInsert label (pLower $ getVarType var) env - ptr = LMStaticPointer var - 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 Global - ptr = LMStaticPointer var - in (env, LMPtoI ptr lmty, []) - -resData env (Left (CmmLabelOff label off)) = - let dflags = getDflags env - (env', var, glob) = resData env (Left (CmmLabel label)) - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - in (env', LMAdd var offset, glob) - -resData env (Left (CmmLabelDiffOff l1 l2 off)) = - let dflags = getDflags env - (env1, var1, glob1) = resData env (Left (CmmLabel l1)) - (env2, var2, glob2) = resData env1 (Left (CmmLabel l2)) - var = LMSub var1 var2 - offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) - in (env2, LMAdd var offset, glob1 ++ glob2) - -resData _ _ = panic "resData: Non CLabel expr as left type!" - -- ---------------------------------------------------------------------------- -- * Generate static data -- -- | Handle static data -genData :: CmmStatic -> UnresStatic +genData :: CmmStatic -> LlvmM LlvmStatic -genData (CmmString str) = +genData (CmmString str) = do let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str ve = v ++ [LMStaticLit $ LMIntLit 0 i8] - in Right $ LMStaticArray ve (LMArray (length ve) i8) + return $ LMStaticArray ve (LMArray (length ve) i8) genData (CmmUninitialised bytes) - = Right $ LMUninitType (LMArray bytes i8) + = return $ LMUninitType (LMArray bytes i8) genData (CmmStaticLit lit) = genStaticLit lit @@ -164,27 +81,47 @@ genData (CmmStaticLit lit) -- -- Will either generate the code or leave it unresolved if it is a 'CLabel' -- which isn't yet known. -genStaticLit :: CmmLit -> UnresStatic +genStaticLit :: CmmLit -> LlvmM LlvmStatic genStaticLit (CmmInt i w) - = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) genStaticLit (CmmFloat r w) - = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) + = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) genStaticLit (CmmVec ls) - = Right $ LMStaticLit (LMVectorLit (map toLlvmLit ls)) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) where - toLlvmLit :: CmmLit -> LlvmLit - toLlvmLit lit = case genStaticLit lit of - Right (LMStaticLit llvmLit) -> llvmLit - _ -> panic "genStaticLit" + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + slit <- genStaticLit lit + case slit of + LMStaticLit llvmLit -> return llvmLit + _ -> panic "genStaticLit" -- Leave unresolved, will fix later -genStaticLit c@(CmmLabel _ ) = Left $ c -genStaticLit c@(CmmLabelOff _ _) = Left $ c -genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c +genStaticLit cmm@(CmmLabel l) = do + var <- getGlobalPtr =<< strCLabel_llvm l + dflags <- getDynFlags + let ptr = LMStaticPointer var + lmty = cmmToLlvmType $ cmmLitType dflags cmm + return $ LMPtoI ptr lmty + +genStaticLit (CmmLabelOff label off) = do + dflags <- getDynFlags + var <- genStaticLit (CmmLabel label) + let offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset + +genStaticLit (CmmLabelDiffOff l1 l2 off) = do + dflags <- getDynFlags + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var = LMSub var1 var2 + offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags) + return $ LMAdd var offset -genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b genStaticLit (CmmHighStackMark) = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 000bac1eae6e..1c63d3f67f71 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -11,7 +11,6 @@ module LlvmCodeGen.Ppr ( import Llvm import LlvmCodeGen.Base import LlvmCodeGen.Data -import LlvmCodeGen.Regs import CLabel import Cmm @@ -28,12 +27,7 @@ import Unique -- | Header code for LLVM modules pprLlvmHeader :: SDoc -pprLlvmHeader = sdocWithDynFlags $ \dflags -> - moduleLayout - $+$ text "" - $+$ ppLlvmFunctionDecls (map snd (ghcInternalFunctions dflags)) - $+$ ppLlvmMetas stgTBAA - $+$ text "" +pprLlvmHeader = moduleLayout -- | LLVM module layout description for the host target @@ -75,63 +69,61 @@ moduleLayout = sdocWithPlatform $ \platform -> -- | Pretty print LLVM data code pprLlvmData :: LlvmData -> SDoc pprLlvmData (globals, types) = - let tryConst (LMGlobal v (Just s)) = ppLlvmGlobal (LMGlobal v $ Just s) - tryConst g@(LMGlobal _ Nothing) = ppLlvmGlobal g - - ppLlvmTys (LMAlias a) = ppLlvmAlias a + let ppLlvmTys (LMAlias a) = ppLlvmAlias a ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f ppLlvmTys _other = empty types' = vcat $ map ppLlvmTys types - globals' = vcat $ map tryConst globals + globals' = ppLlvmGlobals globals in types' $+$ globals' -- | Pretty print LLVM code -pprLlvmCmmDecl :: LlvmEnv -> Int -> LlvmCmmDecl -> (SDoc, [LlvmVar]) -pprLlvmCmmDecl _ _ (CmmData _ lmdata) - = (vcat $ map pprLlvmData lmdata, []) +pprLlvmCmmDecl :: Int -> LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +pprLlvmCmmDecl _ (CmmData _ lmdata) + = return (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmDecl env count (CmmProc mb_info entry_lbl live (ListGraph blks)) - = let (idoc, ivar) = case mb_info of - Nothing -> (empty, []) +pprLlvmCmmDecl count (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do (idoc, ivar) <- case mb_info of + Nothing -> return (empty, []) Just (Statics info_lbl dat) - -> pprInfoTable env count info_lbl (Statics entry_lbl dat) - in (idoc $+$ ( - let sec = mkLayoutSection (count + 1) - (lbl',sec') = case mb_info of + -> pprInfoTable count info_lbl (Statics entry_lbl dat) + + let sec = mkLayoutSection (count + 1) + (lbl',sec') = case mb_info of Nothing -> (entry_lbl, Nothing) Just (Statics info_lbl _) -> (info_lbl, sec) - link = if externallyVisibleCLabel lbl' + link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal - lmblocks = map (\(BasicBlock id stmts) -> + lmblocks = map (\(BasicBlock id stmts) -> LlvmBlock (getUnique id) stmts) blks - fun = mkLlvmFunc env live lbl' link sec' lmblocks - in ppLlvmFunction fun - ), ivar) + + fun <- mkLlvmFunc live lbl' link sec' lmblocks + + return (idoc $+$ ppLlvmFunction fun, ivar) -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (SDoc, [LlvmVar]) -pprInfoTable env count info_lbl stat - = let dflags = getDflags env - unres = genLlvmData env (Text, stat) - (_, (ldata, ltypes)) = resolveLlvmData env unres - - setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) - = let sec = mkLayoutSection count - ilabel = strCLabel_llvm env info_lbl - `appendFS` fsLit iTableSuf - gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c - v = if l == Internal then [gv] else [] - in (LMGlobal gv d, v) - setSection v = (v,[]) - - (ldata', llvmUsed) = setSection (last ldata) - in if length ldata /= 1 +pprInfoTable :: Int -> CLabel -> CmmStatics -> LlvmM (SDoc, [LlvmVar]) +pprInfoTable count info_lbl stat + = do (ldata, ltypes) <- genLlvmData (Text, stat) + + dflags <- getDynFlags + let setSection (LMGlobal (LMGlobalVar _ ty l _ _ c) d) = do + lbl <- strCLabel_llvm info_lbl + let sec = mkLayoutSection count + ilabel = lbl `appendFS` fsLit iTableSuf + gv = LMGlobalVar ilabel ty l sec (llvmInfAlign dflags) c + v = if l == Internal then [gv] else [] + funInsert ilabel ty + return (LMGlobal gv d, v) + setSection v = return (v,[]) + + (ldata', llvmUsed) <- setSection (last ldata) + if length ldata /= 1 then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!" - else (pprLlvmData ([ldata'], ltypes), llvmUsed) + else return (pprLlvmData ([ldata'], ltypes), llvmUsed) -- | We generate labels for info tables by converting them to the same label diff --git a/compiler/llvmGen/LlvmCodeGen/Regs.hs b/compiler/llvmGen/LlvmCodeGen/Regs.hs index dad355d8c50c..1b8792949910 100644 --- a/compiler/llvmGen/LlvmCodeGen/Regs.hs +++ b/compiler/llvmGen/LlvmCodeGen/Regs.hs @@ -4,7 +4,7 @@ module LlvmCodeGen.Regs ( lmGlobalRegArg, lmGlobalRegVar, alwaysLive, - stgTBAA, top, base, stack, heap, rx, other, tbaa, getTBAA + stgTBAA, baseN, stackN, heapN, rxN, otherN, tbaa, getTBAA ) where #include "HsVersions.h" @@ -15,6 +15,7 @@ import CmmExpr import DynFlags import FastString import Outputable ( panic ) +import Unique -- | Get the LlvmVar function variable storing the real register lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar @@ -76,48 +77,38 @@ lmGlobalReg dflags suf reg alwaysLive :: [GlobalReg] alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] --- | STG Type Based Alias Analysis metadata -stgTBAA :: [MetaDecl] +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] stgTBAA - = [ MetaUnamed topN $ MetaStr (fsLit "top") - , MetaUnamed stackN $ MetaStruct [MetaStr (fsLit "stack"), MetaNode topN] - , MetaUnamed heapN $ MetaStruct [MetaStr (fsLit "heap"), MetaNode topN] - , MetaUnamed rxN $ MetaStruct [MetaStr (fsLit "rx"), MetaNode heapN] - , MetaUnamed baseN $ MetaStruct [MetaStr (fsLit "base"), MetaNode topN] + = [ (topN, fsLit "top", Nothing) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) -- FIX: Not 100% sure about 'others' place. Might need to be under 'heap'. -- OR I think the big thing is Sp is never aliased, so might want -- to change the hieracy to have Sp on its own branch that is never -- aliased (e.g never use top as a TBAA node). - , MetaUnamed otherN $ MetaStruct [MetaStr (fsLit "other"), MetaNode topN] + , (otherN, fsLit "other", Just topN) ] -- | Id values -topN, stackN, heapN, rxN, baseN, otherN:: Int -topN = 0 -stackN = 1 -heapN = 2 -rxN = 3 -baseN = 4 -otherN = 5 - --- | The various TBAA types -top, heap, stack, rx, base, other :: MetaAnnot -top = MetaAnnot tbaa (MetaNode topN) -heap = MetaAnnot tbaa (MetaNode heapN) -stack = MetaAnnot tbaa (MetaNode stackN) -rx = MetaAnnot tbaa (MetaNode rxN) -base = MetaAnnot tbaa (MetaNode baseN) -other = MetaAnnot tbaa (MetaNode otherN) +topN, stackN, heapN, rxN, baseN, otherN :: Unique +topN = getUnique (fsLit "LlvmCodeGen.Regs.topN") +stackN = getUnique (fsLit "LlvmCodeGen.Regs.stackN") +heapN = getUnique (fsLit "LlvmCodeGen.Regs.heapN") +rxN = getUnique (fsLit "LlvmCodeGen.Regs.rxN") +baseN = getUnique (fsLit "LlvmCodeGen.Regs.baseN") +otherN = getUnique (fsLit "LlvmCodeGen.Regs.otherN") -- | The TBAA metadata identifier tbaa :: LMString tbaa = fsLit "tbaa" -- | Get the correct TBAA metadata information for this register type -getTBAA :: GlobalReg -> MetaAnnot -getTBAA BaseReg = base -getTBAA Sp = stack -getTBAA Hp = heap -getTBAA (VanillaReg _ _) = rx -getTBAA _ = top - +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _ _) = rxN +getTBAA _ = topN diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index f94030306d84..b8b187241b71 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -168,13 +168,9 @@ outputLlvm :: DynFlags -> FilePath -> Stream IO RawCmmGroup () -> IO () outputLlvm dflags filenm cmm_stream = do ncg_uniqs <- mkSplitUniqSupply 'n' - -- ToDo: make the LLVM backend consume the C-- incrementally, - -- by pushing the cmm_stream inside (c.f. nativeCodeGen) - rawcmms <- Stream.collect cmm_stream - {-# SCC "llvm_output" #-} doOutput filenm $ \f -> {-# SCC "llvm_CodeGen" #-} - llvmCodeGen dflags f ncg_uniqs rawcmms + llvmCodeGen dflags f ncg_uniqs cmm_stream \end{code}