From 1500f0898e85316c7c97a2f759d83278a072ab0e Mon Sep 17 00:00:00 2001 From: Sylvain Henry Date: Mon, 17 Feb 2020 16:21:11 +0100 Subject: Modules: Llvm (#13009) --- compiler/GHC/CmmToLlvm/Base.hs | 685 +++++++++++++ compiler/GHC/CmmToLlvm/CodeGen.hs | 1995 +++++++++++++++++++++++++++++++++++++ compiler/GHC/CmmToLlvm/Data.hs | 196 ++++ compiler/GHC/CmmToLlvm/Mangler.hs | 129 +++ compiler/GHC/CmmToLlvm/Ppr.hs | 100 ++ compiler/GHC/CmmToLlvm/Regs.hs | 136 +++ 6 files changed, 3241 insertions(+) create mode 100644 compiler/GHC/CmmToLlvm/Base.hs create mode 100644 compiler/GHC/CmmToLlvm/CodeGen.hs create mode 100644 compiler/GHC/CmmToLlvm/Data.hs create mode 100644 compiler/GHC/CmmToLlvm/Mangler.hs create mode 100644 compiler/GHC/CmmToLlvm/Ppr.hs create mode 100644 compiler/GHC/CmmToLlvm/Regs.hs (limited to 'compiler/GHC/CmmToLlvm') diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs new file mode 100644 index 0000000000..c0bd742840 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Base.hs @@ -0,0 +1,685 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} + +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +-- ---------------------------------------------------------------------------- +-- | Base LLVM Code Generation module +-- +-- Contains functions useful through out the code generator. +-- + +module GHC.CmmToLlvm.Base ( + + LlvmCmmDecl, LlvmBasicBlock, + LiveGlobalRegs, + LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + + LlvmVersion, supportedLlvmVersion, llvmVersionSupported, parseLlvmVersion, + llvmVersionStr, llvmVersionList, + + LlvmM, + runLlvm, liftStream, withClearVars, varLookup, varInsert, + markStackReg, checkStackReg, + funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform, + dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars, + ghcInternalFunctions, + + getMetaUniqueId, + setUniqMeta, getUniqMeta, + + cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, + llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, + llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR, + + strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm, + getGlobalPtr, generateExternDecls, + + aliasify, llvmDefLabel + ) where + +#include "HsVersions.h" +#include "ghcautoconf.h" + +import GhcPrelude + +import GHC.Llvm +import GHC.CmmToLlvm.Regs + +import GHC.Cmm.CLabel +import GHC.Platform.Regs ( activeStgRegs ) +import DynFlags +import FastString +import GHC.Cmm hiding ( succ ) +import GHC.Cmm.Utils (regsOverlap) +import Outputable as Outp +import GHC.Platform +import UniqFM +import Unique +import BufWrite ( BufHandle ) +import UniqSet +import UniqSupply +import ErrUtils +import qualified Stream + +import Data.Maybe (fromJust) +import Control.Monad (ap) +import Data.Char (isDigit) +import Data.List (sort, groupBy, intercalate) +import qualified Data.List.NonEmpty as NE + +-- ---------------------------------------------------------------------------- +-- * Some Data Types +-- + +type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement) +type LlvmBasicBlock = GenBasicBlock LlvmStatement + +-- | Global registers live on proc entry +type LiveGlobalRegs = [GlobalReg] + +-- | Unresolved code. +-- Of the form: (data label, data type, unresolved data) +type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic]) + +-- | Top level LLVM Data (globals and type aliases) +type LlvmData = ([LMGlobal], [LlvmType]) + +-- | An unresolved Label. +-- +-- Labels are unresolved when we haven't yet determined if they are defined in +-- the module we are currently compiling, or an external one. +type UnresLabel = CmmLit +type UnresStatic = Either UnresLabel LlvmStatic + +-- ---------------------------------------------------------------------------- +-- * Type translations +-- + +-- | Translate a basic CmmType to an LlvmType. +cmmToLlvmType :: CmmType -> LlvmType +cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty)) + | isFloatType ty = widthToLlvmFloat $ typeWidth ty + | otherwise = widthToLlvmInt $ typeWidth ty + +-- | Translate a Cmm Float Width to a LlvmType. +widthToLlvmFloat :: Width -> LlvmType +widthToLlvmFloat W32 = LMFloat +widthToLlvmFloat W64 = LMDouble +widthToLlvmFloat W128 = LMFloat128 +widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w + +-- | Translate a Cmm Bit Width to a LlvmType. +widthToLlvmInt :: Width -> LlvmType +widthToLlvmInt w = LMInt $ widthInBits w + +-- | GHC Call Convention for LLVM +llvmGhcCC :: DynFlags -> LlvmCallConvention +llvmGhcCC dflags + | platformUnregisterised (targetPlatform dflags) = CC_Ccc + | otherwise = CC_Ghc + +-- | Llvm Function type for Cmm function +llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType +llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible + +-- | Llvm Function signature +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) + +-- | Alignment to use for functions +llvmFunAlign :: DynFlags -> LMAlign +llvmFunAlign dflags = Just (wORD_SIZE dflags) + +-- | Alignment to use for into tables +llvmInfAlign :: DynFlags -> LMAlign +llvmInfAlign dflags = Just (wORD_SIZE dflags) + +-- | Section to use for a function +llvmFunSection :: DynFlags -> LMString -> LMSection +llvmFunSection dflags lbl + | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl]) + | otherwise = Nothing + +-- | A Function's arguments +llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar] +llvmFunArgs dflags live = + map (lmGlobalRegArg dflags) (filter isPassed allRegs) + where platform = targetPlatform dflags + allRegs = activeStgRegs platform + paddedLive = map (\(_,r) -> r) $ padLiveArgs dflags live + isLive r = r `elem` alwaysLive || r `elem` paddedLive + isPassed r = not (isFPR r) || isLive r + + +isFPR :: GlobalReg -> Bool +isFPR (FloatReg _) = True +isFPR (DoubleReg _) = True +isFPR (XmmReg _) = True +isFPR (YmmReg _) = True +isFPR (ZmmReg _) = True +isFPR _ = False + +sameFPRClass :: GlobalReg -> GlobalReg -> Bool +sameFPRClass (FloatReg _) (FloatReg _) = True +sameFPRClass (DoubleReg _) (DoubleReg _) = True +sameFPRClass (XmmReg _) (XmmReg _) = True +sameFPRClass (YmmReg _) (YmmReg _) = True +sameFPRClass (ZmmReg _) (ZmmReg _) = True +sameFPRClass _ _ = False + +normalizeFPRNum :: GlobalReg -> GlobalReg +normalizeFPRNum (FloatReg _) = FloatReg 1 +normalizeFPRNum (DoubleReg _) = DoubleReg 1 +normalizeFPRNum (XmmReg _) = XmmReg 1 +normalizeFPRNum (YmmReg _) = YmmReg 1 +normalizeFPRNum (ZmmReg _) = ZmmReg 1 +normalizeFPRNum _ = error "normalizeFPRNum expected only FPR regs" + +getFPRCtor :: GlobalReg -> Int -> GlobalReg +getFPRCtor (FloatReg _) = FloatReg +getFPRCtor (DoubleReg _) = DoubleReg +getFPRCtor (XmmReg _) = XmmReg +getFPRCtor (YmmReg _) = YmmReg +getFPRCtor (ZmmReg _) = ZmmReg +getFPRCtor _ = error "getFPRCtor expected only FPR regs" + +fprRegNum :: GlobalReg -> Int +fprRegNum (FloatReg i) = i +fprRegNum (DoubleReg i) = i +fprRegNum (XmmReg i) = i +fprRegNum (YmmReg i) = i +fprRegNum (ZmmReg i) = i +fprRegNum _ = error "fprRegNum expected only FPR regs" + +-- | Input: dynflags, and the list of live registers +-- +-- Output: An augmented list of live registers, where padding was +-- added to the list of registers to ensure the calling convention is +-- correctly used by LLVM. +-- +-- Each global reg in the returned list is tagged with a bool, which +-- indicates whether the global reg was added as padding, or was an original +-- live register. +-- +-- That is, True => padding, False => a real, live global register. +-- +-- Also, the returned list is not sorted in any particular order. +-- +padLiveArgs :: DynFlags -> LiveGlobalRegs -> [(Bool, GlobalReg)] +padLiveArgs dflags live = + if platformUnregisterised plat + then taggedLive -- not using GHC's register convention for platform. + else padding ++ taggedLive + where + taggedLive = map (\x -> (False, x)) live + plat = targetPlatform dflags + + fprLive = filter isFPR live + padding = concatMap calcPad $ groupBy sharesClass fprLive + + sharesClass :: GlobalReg -> GlobalReg -> Bool + sharesClass a b = sameFPRClass a b || overlappingClass + where + overlappingClass = regsOverlap dflags (norm a) (norm b) + norm = CmmGlobal . normalizeFPRNum + + calcPad :: [GlobalReg] -> [(Bool, GlobalReg)] + calcPad rs = getFPRPadding (getFPRCtor $ head rs) rs + +getFPRPadding :: (Int -> GlobalReg) -> LiveGlobalRegs -> [(Bool, GlobalReg)] +getFPRPadding paddingCtor live = padding + where + fprRegNums = sort $ map fprRegNum live + (_, padding) = foldl assignSlots (1, []) $ fprRegNums + + assignSlots (i, acc) regNum + | i == regNum = -- don't need padding here + (i+1, acc) + | i < regNum = let -- add padding for slots i .. regNum-1 + numNeeded = regNum-i + acc' = genPad i numNeeded ++ acc + in + (regNum+1, acc') + | otherwise = error "padLiveArgs -- i > regNum ??" + + genPad start n = + take n $ flip map (iterate (+1) start) (\i -> + (True, paddingCtor i)) + + +-- | Llvm standard fun attributes +llvmStdFunAttrs :: [LlvmFuncAttr] +llvmStdFunAttrs = [NoUnwind] + +-- | Convert a list of types to a list of function parameters +-- (each with no parameter attributes) +tysToParams :: [LlvmType] -> [LlvmParameter] +tysToParams = map (\ty -> (ty, [])) + +-- | Pointer width +llvmPtrBits :: DynFlags -> Int +llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags + +-- ---------------------------------------------------------------------------- +-- * Llvm Version +-- + +-- Newtype to avoid using the Eq instance! +newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int } + +parseLlvmVersion :: String -> Maybe LlvmVersion +parseLlvmVersion = + fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit) + where + go vs s + | null ver_str + = reverse vs + | '.' : rest' <- rest + = go (read ver_str : vs) rest' + | otherwise + = reverse (read ver_str : vs) + where + (ver_str, rest) = span isDigit s + +-- | The LLVM Version that is currently supported. +supportedLlvmVersion :: LlvmVersion +supportedLlvmVersion = LlvmVersion (sUPPORTED_LLVM_VERSION NE.:| []) + +llvmVersionSupported :: LlvmVersion -> Bool +llvmVersionSupported (LlvmVersion v) = NE.head v == sUPPORTED_LLVM_VERSION + +llvmVersionStr :: LlvmVersion -> String +llvmVersionStr = intercalate "." . map show . llvmVersionList + +llvmVersionList :: LlvmVersion -> [Int] +llvmVersionList = NE.toList . llvmVersionNE + +-- ---------------------------------------------------------------------------- +-- * Environment Handling +-- + +data LlvmEnv = LlvmEnv + { envVersion :: LlvmVersion -- ^ LLVM version + , envDynFlags :: DynFlags -- ^ Dynamic flags + , envOutput :: BufHandle -- ^ Output buffer + , envMask :: !Char -- ^ Mask for creating unique values + , envFreshMeta :: MetaId -- ^ Supply of fresh metadata IDs + , envUniqMeta :: UniqFM MetaId -- ^ Global metadata nodes + , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type + , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References] + , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@) + + -- the following get cleared for every function (see @withClearVars@) + , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type + , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude) + } + +type LlvmEnvMap = UniqFM LlvmType + +-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad +newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) } + deriving (Functor) + +instance Applicative LlvmM where + pure x = LlvmM $ \env -> return (x, env) + (<*>) = ap + +instance Monad LlvmM where + m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env + runLlvmM (f x) env' + +instance HasDynFlags LlvmM where + getDynFlags = LlvmM $ \env -> return (envDynFlags env, env) + +instance MonadUnique LlvmM where + getUniqueSupplyM = do + mask <- getEnv envMask + liftIO $! mkSplitUniqSupply mask + + getUniqueM = do + mask <- getEnv envMask + liftIO $! uniqFromMask mask + +-- | Lifting of IO actions. Not exported, as we want to encapsulate IO. +liftIO :: IO a -> LlvmM a +liftIO m = LlvmM $ \env -> do x <- m + return (x, env) + +-- | Get initial Llvm environment. +runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a +runLlvm dflags ver out m = do + (a, _) <- runLlvmM m env + return a + where env = LlvmEnv { envFunMap = emptyUFM + , envVarMap = emptyUFM + , envStackRegs = [] + , envUsedVars = [] + , envAliases = emptyUniqSet + , envVersion = ver + , envDynFlags = dflags + , envOutput = out + , envMask = 'n' + , envFreshMeta = MetaId 0 + , envUniqMeta = emptyUFM + } + +-- | 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 MetaId +getMetaUniqueId = LlvmM $ \env -> + return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env }) + +-- | Get the LLVM version we are generating code for +getLlvmVer :: LlvmM LlvmVersion +getLlvmVer = getEnv envVersion + +-- | 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 :: LlvmM Platform +getLlvmPlatform = getDynFlag targetPlatform + +-- | Dumps the document if the corresponding flag has been set by the user +dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM () +dumpIfSetLlvm flag hdr fmt doc = do + dflags <- getDynFlags + liftIO $ dumpIfSet_dyn dflags flag hdr fmt doc + +-- | Prints the given contents to the output handle +renderLlvm :: Outp.SDoc -> LlvmM () +renderLlvm sdoc = do + + -- Write to output + dflags <- getDynFlags + out <- getEnv envOutput + liftIO $ Outp.bufLeftRenderSDoc dflags out + (Outp.mkCodeStyle Outp.CStyle) sdoc + + -- Dump, if requested + dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc + return () + +-- | 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 -> MetaId -> LlvmM () +setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m } + +-- | Gets metadata node for given unique +getUniqMeta :: Unique -> LlvmM (Maybe MetaId) +getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta) + +-- ---------------------------------------------------------------------------- +-- * Internal functions +-- + +-- | 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' = llvmDefLabel $ 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 :: CLabel -> LlvmM LMString +strCLabel_llvm lbl = do + dflags <- getDynFlags + let sdoc = pprCLabel dflags lbl + str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle) + return (fsLit str) + +strDisplayName_llvm :: CLabel -> LlvmM LMString +strDisplayName_llvm lbl = do + dflags <- getDynFlags + let sdoc = pprCLabel dflags lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify 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 + dflags <- getDynFlags + let sdoc = pprCLabel dflags lbl + depth = Outp.PartWay 1 + style = Outp.mkUserStyle dflags Outp.neverQualify 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 (llvmDefLabel llvmLbl) ty Global + -- Otherwise use a forward alias of it + Nothing -> do + saveAlias llvmLbl + return $ mkGlbVar llvmLbl i8 Alias + +-- | Derive the definition label. It has an identified +-- structure type. +llvmDefLabel :: LMString -> LMString +llvmDefLabel = (`appendFS` fsLit "$def") + +-- | 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! +generateExternDecls :: LlvmM ([LMGlobal], [LlvmType]) +generateExternDecls = do + delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases + -- This is non-deterministic but we do not + -- currently support deterministic code-generation. + -- See Note [Unique Determinism and code generation] + defss <- flip mapM delayed $ \lbl -> do + m_ty <- funLookup lbl + case m_ty of + -- If we have a definition we've already emitted the proper aliases + -- when the symbol itself was emitted by @aliasify@ + Just _ -> return [] + + -- If we don't have a definition this is an external symbol and we + -- need to emit a declaration + Nothing -> + let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global + in return [LMGlobal var Nothing] + + -- Reset forward list + modifyEnv $ \env -> env { envAliases = emptyUniqSet } + return (concat defss, []) + +-- | Here we take a global variable definition, rename it with a +-- @$def@ suffix, and generate the appropriate alias. +aliasify :: LMGlobal -> LlvmM [LMGlobal] +-- See note [emit-time elimination of static indirections] in CLabel. +-- Here we obtain the indirectee's precise type and introduce +-- fresh aliases to both the precise typed label (lbl$def) and the i8* +-- typed (regular) label of it with the matching new names. +aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias) + (Just orig)) = do + let defLbl = llvmDefLabel lbl + LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig + defOrigLbl = llvmDefLabel origLbl + orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias) + origType <- funLookup origLbl + let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl + (pLift $ fromJust origType) oLnk + Nothing Nothing Alias)) + (pLift ty) + pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig) + , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig') + ] +aliasify (LMGlobal var val) = do + let LMGlobalVar lbl ty link sect align const = var + + defLbl = llvmDefLabel lbl + defVar = LMGlobalVar defLbl ty Internal sect align const + + defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const + aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias + aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr + + -- we need to mark the $def symbols as used so LLVM doesn't forget which + -- section they need to go in. This will vanish once we switch away from + -- mangling sections for TNTC. + markUsedVar defVar + + return [ LMGlobal defVar val + , LMGlobal aliasVar (Just aliasVal) + ] + +-- 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. +-- +-- In particular when we encounter a reference to a symbol in a chunk of +-- C-- there are three possible scenarios, +-- +-- 1. We have already seen a definition for the referenced symbol. This +-- means we already know its type. +-- +-- 2. We have not yet seen a definition but we will find one later in this +-- compilation unit. Since we want to be a good consumer of the +-- C-- streamed to us from upstream, we don't know the type of the +-- symbol at the time when we must emit the reference. +-- +-- 3. We have not yet seen a definition nor will we find one in this +-- compilation unit. In this case the reference refers to an +-- external symbol for which we do not know the type. +-- +-- Let's consider case (2) for a moment: say we see a reference to +-- the symbol @fooBar@ for which we have not seen a definition. As we +-- do not know the symbol's type, we assume it is of type @i8*@ and emit +-- the appropriate casts in @getSymbolPtr@. Later on, when we +-- encounter the definition of @fooBar@ we emit it but with a modified +-- name, @fooBar$def@ (which we'll call the definition symbol), to +-- since we have already had to assume that the symbol @fooBar@ +-- is of type @i8*@. We then emit @fooBar@ itself as an alias +-- of @fooBar$def@ with appropriate casts. This all happens in +-- @aliasify@. +-- +-- Case (3) is quite similar to (2): References are emitted assuming +-- the referenced symbol is of type @i8*@. When we arrive at the end of +-- the compilation unit and realize that the symbol is external, we emit +-- an LLVM @external global@ declaration for the symbol @fooBar@ +-- (handled in @generateExternDecls@). This takes advantage of the +-- fact that the aliases produced by @aliasify@ for exported symbols +-- have external linkage and can therefore be used as normal symbols. +-- +-- Historical note: As of release 3.5 LLVM does not allow aliases to +-- refer to declarations. This the reason why aliases are produced at the +-- point of definition instead of the point of usage, as was previously +-- done. See #9142 for details. +-- +-- Finally, case (1) is trivial. As we already have a definition for +-- and therefore know the type of the referenced symbol, we can do +-- away with casting the alias to the desired type in @getSymbolPtr@ +-- and instead just emit a reference to the definition symbol directly. +-- This is the @Just@ case in @getSymbolPtr@. diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs new file mode 100644 index 0000000000..33dd82c418 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/CodeGen.hs @@ -0,0 +1,1995 @@ +{-# LANGUAGE CPP, GADTs #-} +{-# OPTIONS_GHC -fno-warn-type-defaults #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmProc to LLVM code. +-- +module GHC.CmmToLlvm.CodeGen ( genLlvmProc ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Regs + +import GHC.Cmm.BlockId +import GHC.Platform.Regs ( activeStgRegs ) +import GHC.Cmm.CLabel +import GHC.Cmm +import GHC.Cmm.Ppr as PprCmm +import GHC.Cmm.Utils +import GHC.Cmm.Switch +import GHC.Cmm.Dataflow.Block +import GHC.Cmm.Dataflow.Graph +import GHC.Cmm.Dataflow.Collections + +import DynFlags +import FastString +import ForeignCall +import Outputable hiding (panic, pprPanic) +import qualified Outputable +import GHC.Platform +import OrdList +import UniqSupply +import Unique +import Util + +import Control.Monad.Trans.Class +import Control.Monad.Trans.Writer + +import qualified Data.Semigroup as Semigroup +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) + +type Atomic = Bool +type LlvmStatements = OrdList LlvmStatement + +data Signage = Signed | Unsigned deriving (Eq, Show) + +-- ----------------------------------------------------------------------------- +-- | Top-level of the LLVM proc Code generator +-- +genLlvmProc :: RawCmmDecl -> LlvmM [LlvmCmmDecl] +genLlvmProc (CmmProc infos lbl live graph) = do + let blocks = toBlockListEntryFirstFalseFallthrough graph + (lmblocks, lmdata) <- basicBlocksCodeGen live blocks + let info = mapLookup (g_entry graph) infos + proc = CmmProc info lbl live (ListGraph lmblocks) + return (proc:lmdata) + +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. The first block in the list is expected to be the entry +-- point. +basicBlocksCodeGen :: LiveGlobalRegs -> [CmmBlock] + -> LlvmM ([LlvmBasicBlock], [LlvmCmmDecl]) +basicBlocksCodeGen _ [] = panic "no entry block!" +basicBlocksCodeGen live cmmBlocks + = do -- Emit the prologue + -- N.B. this must be its own block to ensure that the entry block of the + -- procedure has no predecessors, as required by the LLVM IR. See #17589 + -- and #11649. + bid <- newBlockId + (prologue, prologueTops) <- funPrologue live cmmBlocks + let entryBlock = BasicBlock bid (fromOL prologue) + + -- Generate code + (blocks, topss) <- fmap unzip $ mapM basicBlockCodeGen cmmBlocks + + -- Compose + return (entryBlock : blocks, prologueTops ++ concat topss) + + +-- | Generate code for one block +basicBlockCodeGen :: CmmBlock -> LlvmM ( LlvmBasicBlock, [LlvmCmmDecl] ) +basicBlockCodeGen block + = do let (_, nodes, tail) = blockSplit block + id = entryLabel block + (mid_instrs, top) <- stmtsToInstrs $ blockToList nodes + (tail_instrs, top') <- stmtToInstrs tail + let instrs = fromOL (mid_instrs `appOL` tail_instrs) + return (BasicBlock id instrs, top' ++ top) + +-- ----------------------------------------------------------------------------- +-- * CmmNode code generation +-- + +-- A statement conversion return data. +-- * LlvmStatements: The compiled LLVM statements. +-- * LlvmCmmDecl: Any global data needed. +type StmtData = (LlvmStatements, [LlvmCmmDecl]) + + +-- | Convert a list of CmmNode's to LlvmStatement's +stmtsToInstrs :: [CmmNode e x] -> LlvmM StmtData +stmtsToInstrs stmts + = do (instrss, topss) <- fmap unzip $ mapM stmtToInstrs stmts + return (concatOL instrss, concat topss) + + +-- | Convert a CmmStmt to a list of LlvmStatement's +stmtToInstrs :: CmmNode e x -> LlvmM StmtData +stmtToInstrs stmt = case stmt of + + CmmComment _ -> return (nilOL, []) -- nuke comments + CmmTick _ -> return (nilOL, []) + CmmUnwind {} -> return (nilOL, []) + + CmmAssign reg src -> genAssign reg src + CmmStore addr src -> genStore addr src + + CmmBranch id -> genBranch id + CmmCondBranch arg true false likely + -> genCondBranch arg true false likely + CmmSwitch arg ids -> genSwitch arg ids + + -- Foreign Call + CmmUnsafeForeignCall target res args + -> genCall target res args + + -- Tail call + CmmCall { cml_target = arg, + 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 + un <- getUniqueM + let lbl = mkAsmTempLabel un + return [CmmData (Section Data lbl) [([],[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 :: LlvmM StmtData +barrier = do + let s = Fence False SyncSeqCst + return (unitOL s, []) + +-- | Insert a 'barrier', unless the target platform is in the provided list of +-- exceptions (where no code will be emitted instead). +barrierUnless :: [Arch] -> LlvmM StmtData +barrierUnless exs = do + platform <- getLlvmPlatform + if platformArch platform `elem` exs + then return (nilOL, []) + else barrier + +-- | Foreign Calls +genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData + +-- Barriers need to be handled specially as they are implemented as LLVM +-- intrinsic functions. +genCall (PrimTarget MO_ReadBarrier) _ _ = + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] +genCall (PrimTarget MO_WriteBarrier) _ _ = do + barrierUnless [ArchX86, ArchX86_64, ArchSPARC] + +genCall (PrimTarget MO_Touch) _ _ + = return (nilOL, []) + +genCall (PrimTarget (MO_UF_Conv w)) [dst] [e] = runStmtsDecls $ do + dstV <- getCmmRegW (CmmLocal dst) + let ty = cmmToLlvmType $ localRegType dst + width = widthToLlvmFloat w + castV <- lift $ mkLocalVar ty + ve <- exprToVarW e + statement $ Assignment castV $ Cast LM_Uitofp ve width + statement $ Store castV dstV + +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 t@(PrimTarget (MO_Prefetch_Data localityInt)) [] args + | 0 <= localityInt && localityInt <= 3 = runStmtsDecls $ 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 + argVars <- arg_varsW args_hints' ([], nilOL, []) + fptr <- liftExprData $ getFunPtr funTy t + argVars' <- castVarsW Signed $ zip argVars argTy + + let argSuffix = [mkIntLit i32 0, mkIntLit i32 localityInt, mkIntLit i32 1] + statement $ Expr $ Call StdCall fptr (argVars' ++ argSuffix) [] + | otherwise = panic $ "prefetch locality level integer must be between 0 and 3, given: " ++ (show localityInt) + +-- Handle PopCnt, Clz, Ctz, and BSwap that need to only convert arg +-- and return types +genCall t@(PrimTarget (MO_PopCnt w)) dsts args = + genCallSimpleCast w t dsts args + +genCall t@(PrimTarget (MO_Pdep w)) dsts args = + genCallSimpleCast2 w t dsts args +genCall t@(PrimTarget (MO_Pext w)) dsts args = + genCallSimpleCast2 w t dsts args +genCall t@(PrimTarget (MO_Clz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_Ctz w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BSwap w)) dsts args = + genCallSimpleCast w t dsts args +genCall t@(PrimTarget (MO_BRev w)) dsts args = + genCallSimpleCast w t dsts args + +genCall (PrimTarget (MO_AtomicRMW width amop)) [dst] [addr, n] = runStmtsDecls $ do + addrVar <- exprToVarW addr + nVar <- exprToVarW n + let targetTy = widthToLlvmInt width + ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) + ptrVar <- doExprW (pLift targetTy) ptrExpr + dstVar <- getCmmRegW (CmmLocal dst) + let op = case amop of + AMO_Add -> LAO_Add + AMO_Sub -> LAO_Sub + AMO_And -> LAO_And + AMO_Nand -> LAO_Nand + AMO_Or -> LAO_Or + AMO_Xor -> LAO_Xor + retVar <- doExprW targetTy $ AtomicRMW op ptrVar nVar SyncSeqCst + statement $ Store retVar dstVar + +genCall (PrimTarget (MO_AtomicRead _)) [dst] [addr] = runStmtsDecls $ do + dstV <- getCmmRegW (CmmLocal dst) + v1 <- genLoadW True addr (localRegType dst) + statement $ Store v1 dstV + +genCall (PrimTarget (MO_Cmpxchg _width)) + [dst] [addr, old, new] = runStmtsDecls $ do + addrVar <- exprToVarW addr + oldVar <- exprToVarW old + newVar <- exprToVarW new + let targetTy = getVarType oldVar + ptrExpr = Cast LM_Inttoptr addrVar (pLift targetTy) + ptrVar <- doExprW (pLift targetTy) ptrExpr + dstVar <- getCmmRegW (CmmLocal dst) + retVar <- doExprW (LMStructU [targetTy,i1]) + $ CmpXChg ptrVar oldVar newVar SyncSeqCst SyncSeqCst + retVar' <- doExprW targetTy $ ExtractV retVar 0 + statement $ Store retVar' dstVar + +genCall (PrimTarget (MO_AtomicWrite _width)) [] [addr, val] = runStmtsDecls $ do + addrVar <- exprToVarW addr + valVar <- exprToVarW val + let ptrTy = pLift $ getVarType valVar + ptrExpr = Cast LM_Inttoptr addrVar ptrTy + ptrVar <- doExprW ptrTy ptrExpr + statement $ Expr $ AtomicRMW LAO_Xchg ptrVar valVar SyncSeqCst + +-- Handle memcpy function specifically since llvm's intrinsic version takes +-- some extra parameters. +genCall t@(PrimTarget op) [] args + | Just align <- machOpMemcpyishAlign op = runStmtsDecls $ do + dflags <- getDynFlags + let isVolTy = [i1] + isVolVal = [mkIntLit i1 0] + argTy | MO_Memset _ <- op = [i8Ptr, i8, llvmWord dflags, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord dflags, i32] ++ isVolTy + 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 + argVars <- arg_varsW args_hints ([], nilOL, []) + fptr <- getFunPtrW funTy t + argVars' <- castVarsW Signed $ zip argVars argTy + + let alignVal = mkIntLit i32 align + arguments = argVars' ++ (alignVal:isVolVal) + statement $ Expr $ Call StdCall fptr arguments [] + +-- We handle MO_U_Mul2 by simply using a 'mul' instruction, but with operands +-- twice the width (we first zero-extend them), e.g., on 64-bit arch we will +-- generate 'mul' on 128-bit operands. Then we only need some plumbing to +-- extract the two 64-bit values out of 128-bit result. +genCall (PrimTarget (MO_U_Mul2 w)) [dstH, dstL] [lhs, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend the operands ('mul' instruction requires the operands + -- and the result to be of the same type). Note that we don't use 'castVars' + -- because it tries to do LM_Sext. + lhsVar <- exprToVarW lhs + rhsVar <- exprToVarW rhs + lhsExt <- doExprW width2x $ Cast LM_Zext lhsVar width2x + rhsExt <- doExprW width2x $ Cast LM_Zext rhsVar width2x + -- Do the actual multiplication (note that the result is also 2x width). + retV <- doExprW width2x $ LlvmOp LM_MO_Mul lhsExt rhsExt + -- Extract the lower bits of the result into retL. + retL <- doExprW width $ Cast LM_Trunc retV width + -- Now we right-shift the higher bits by width. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + retShifted <- doExprW width2x $ LlvmOp LM_MO_LShr retV widthLlvmLit + -- And extract them into retH. + retH <- doExprW width $ Cast LM_Trunc retShifted width + dstRegL <- getCmmRegW (CmmLocal dstL) + dstRegH <- getCmmRegW (CmmLocal dstH) + statement $ Store retL dstRegL + statement $ Store retH dstRegH + +-- MO_U_QuotRem2 is another case we handle by widening the registers to double +-- the width and use normal LLVM instructions (similarly to the MO_U_Mul2). The +-- main difference here is that we need to combine two words into one register +-- and then use both 'udiv' and 'urem' instructions to compute the result. +genCall (PrimTarget (MO_U_QuotRem2 w)) + [dstQ, dstR] [lhsH, lhsL, rhs] = runStmtsDecls $ do + let width = widthToLlvmInt w + bitWidth = widthInBits w + width2x = LMInt (bitWidth * 2) + -- First zero-extend all parameters to double width. + let zeroExtend expr = do + var <- exprToVarW expr + doExprW width2x $ Cast LM_Zext var width2x + lhsExtH <- zeroExtend lhsH + lhsExtL <- zeroExtend lhsL + rhsExt <- zeroExtend rhs + -- Now we combine the first two parameters (that represent the high and low + -- bits of the value). So first left-shift the high bits to their position + -- and then bit-or them with the low bits. + let widthLlvmLit = LMLitVar $ LMIntLit (fromIntegral bitWidth) width + lhsExtHShifted <- doExprW width2x $ LlvmOp LM_MO_Shl lhsExtH widthLlvmLit + lhsExt <- doExprW width2x $ LlvmOp LM_MO_Or lhsExtHShifted lhsExtL + -- Finally, we can call 'udiv' and 'urem' to compute the results. + retExtDiv <- doExprW width2x $ LlvmOp LM_MO_UDiv lhsExt rhsExt + retExtRem <- doExprW width2x $ LlvmOp LM_MO_URem lhsExt rhsExt + -- And since everything is in 2x width, we need to truncate the results and + -- then return them. + let narrow var = doExprW width $ Cast LM_Trunc var width + retDiv <- narrow retExtDiv + retRem <- narrow retExtRem + dstRegQ <- lift $ getCmmReg (CmmLocal dstQ) + dstRegR <- lift $ getCmmReg (CmmLocal dstR) + statement $ Store retDiv dstRegQ + statement $ Store retRem dstRegR + +-- Handle the MO_{Add,Sub}IntC separately. LLVM versions return a record from +-- which we need to extract the actual values. +genCall t@(PrimTarget (MO_AddIntC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] +genCall t@(PrimTarget (MO_SubIntC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +-- Similar to MO_{Add,Sub}IntC, but MO_Add2 expects the first element of the +-- return tuple to be the overflow bit and the second element to contain the +-- actual result of the addition. So we still use genCallWithOverflow but swap +-- the return registers. +genCall t@(PrimTarget (MO_Add2 w)) [dstO, dstV] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall t@(PrimTarget (MO_AddWordC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +genCall t@(PrimTarget (MO_SubWordC w)) [dstV, dstO] [lhs, rhs] = + genCallWithOverflow t w [dstV, dstO] [lhs, rhs] + +-- Handle all other foreign calls and prim ops. +genCall target res args = runStmtsDecls $ do + dflags <- getDynFlags + + -- parameter types + let arg_type (_, AddrHint) = i8Ptr + -- cast pointers to i8*. Llvm equivalent of void* + arg_type (expr, _) = cmmToLlvmType $ cmmExprType dflags expr + + -- ret type + let ret_type [] = LMVoid + ret_type [(_, AddrHint)] = i8Ptr + ret_type [(reg, _)] = cmmToLlvmType $ localRegType reg + ret_type t = panic $ "genCall: Too many return values! Can only handle" + ++ " 0 or 1, given " ++ show (length t) ++ "." + + -- extract Cmm call convention, and translate to LLVM call convention + platform <- lift $ getLlvmPlatform + let lmconv = case target of + ForeignTarget _ (ForeignConvention conv _ _ _) -> + case conv of + StdCallConv -> case platformArch platform of + ArchX86 -> CC_X86_Stdcc + ArchX86_64 -> CC_X86_Stdcc + _ -> CC_Ccc + CCallConv -> CC_Ccc + CApiConv -> CC_Ccc + PrimCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: PrimCallConv" + JavaScriptCallConv -> panic "GHC.CmmToLlvm.CodeGen.genCall: JavaScriptCallConv" + + PrimTarget _ -> CC_Ccc + + {- + CC_Ccc of the possibilities here are a worry with the use of a custom + calling convention for passing STG args. In practice the more + dangerous combinations (e.g StdCall + llvmGhcCC) don't occur. + + The native code generator only handles StdCall and CCallConv. + -} + + -- call attributes + let fnAttrs | never_returns = NoReturn : llvmStdFunAttrs + | otherwise = llvmStdFunAttrs + + never_returns = case target of + ForeignTarget _ (ForeignConvention _ _ _ CmmNeverReturns) -> True + _ -> False + + -- fun type + let (res_hints, arg_hints) = foreignTargetHints target + let args_hints = zip args arg_hints + let ress_hints = zip res res_hints + let ccTy = StdCall -- tail calls should be done through CmmJump + let retTy = ret_type ress_hints + let argTy = tysToParams $ map arg_type args_hints + let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + lmconv retTy FixedArgs argTy (llvmFunAlign dflags) + + + argVars <- arg_varsW args_hints ([], nilOL, []) + fptr <- getFunPtrW funTy target + + let doReturn | ccTy == TailCall = statement $ Return Nothing + | never_returns = statement $ Unreachable + | otherwise = return () + + + -- make the actual call + case retTy of + LMVoid -> do + statement $ Expr $ Call ccTy fptr argVars fnAttrs + + _ -> do + v1 <- doExprW retTy $ Call ccTy fptr argVars fnAttrs + -- get the return register + let ret_reg [reg] = reg + ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" + ++ " 1, given " ++ show (length t) ++ "." + let creg = ret_reg res + vreg <- getCmmRegW (CmmLocal creg) + if retTy == pLower (getVarType vreg) + then do + statement $ Store v1 vreg + doReturn + else do + let ty = pLower $ getVarType vreg + let op = case ty of + vt | isPointer vt -> LM_Bitcast + | isInt vt -> LM_Ptrtoint + | otherwise -> + panic $ "genCall: CmmReg bad match for" + ++ " returned type!" + + v2 <- doExprW ty $ Cast op v1 ty + statement $ Store v2 vreg + doReturn + +-- | Generate a call to an LLVM intrinsic that performs arithmetic operation +-- with overflow bit (i.e., returns a struct containing the actual result of the +-- operation and an overflow bit). This function will also extract the overflow +-- bit and zero-extend it (all the corresponding Cmm PrimOps represent the +-- overflow "bit" as a usual Int# or Word#). +genCallWithOverflow + :: ForeignTarget -> Width -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData +genCallWithOverflow t@(PrimTarget op) w [dstV, dstO] [lhs, rhs] = do + -- So far this was only tested for the following four CallishMachOps. + let valid = op `elem` [ MO_Add2 w + , MO_AddIntC w + , MO_SubIntC w + , MO_AddWordC w + , MO_SubWordC w + ] + MASSERT(valid) + let width = widthToLlvmInt w + -- This will do most of the work of generating the call to the intrinsic and + -- extracting the values from the struct. + (value, overflowBit, (stmts, top)) <- + genCallExtract t w (lhs, rhs) (width, i1) + -- value is i, but overflowBit is i1, so we need to cast (Cmm expects + -- both to be i) + (overflow, zext) <- doExpr width $ Cast LM_Zext overflowBit width + dstRegV <- getCmmReg (CmmLocal dstV) + dstRegO <- getCmmReg (CmmLocal dstO) + let storeV = Store value dstRegV + storeO = Store overflow dstRegO + return (stmts `snocOL` zext `snocOL` storeV `snocOL` storeO, top) +genCallWithOverflow _ _ _ _ = + panic "genCallExtract: wrong ForeignTarget or number of arguments" + +-- | A helper function for genCallWithOverflow that handles generating the call +-- to the LLVM intrinsic and extracting the result from the struct to LlvmVars. +genCallExtract + :: ForeignTarget -- ^ PrimOp + -> Width -- ^ Width of the operands. + -> (CmmActual, CmmActual) -- ^ Actual arguments. + -> (LlvmType, LlvmType) -- ^ LLVM types of the returned struct. + -> LlvmM (LlvmVar, LlvmVar, StmtData) +genCallExtract target@(PrimTarget op) w (argA, argB) (llvmTypeA, llvmTypeB) = do + let width = widthToLlvmInt w + argTy = [width, width] + retTy = LMStructU [llvmTypeA, llvmTypeB] + + -- Process the arguments. + let args_hints = zip [argA, argB] (snd $ foreignTargetHints target) + (argsV1, args1, top1) <- arg_vars args_hints ([], nilOL, []) + (argsV2, args2) <- castVars Signed $ zip argsV1 argTy + + -- Get the function and make the call. + fname <- cmmPrimOpFunctions op + (fptr, _, top2) <- getInstrinct fname retTy argTy + -- We use StdCall for primops. See also the last case of genCall. + (retV, call) <- doExpr retTy $ Call StdCall fptr argsV2 [] + + -- This will result in a two element struct, we need to use "extractvalue" + -- to get them out of it. + (res1, ext1) <- doExpr llvmTypeA (ExtractV retV 0) + (res2, ext2) <- doExpr llvmTypeB (ExtractV retV 1) + + let stmts = args1 `appOL` args2 `snocOL` call `snocOL` ext1 `snocOL` ext2 + tops = top1 ++ top2 + return (res1, res2, (stmts, tops)) + +genCallExtract _ _ _ _ = + panic "genCallExtract: unsupported ForeignTarget" + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- 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. +genCallSimpleCast :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType 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 + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars Signed $ zip argsV [width] + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] + let retV' = singletonPanic "genCallSimpleCast" retVs' + let s2 = Store retV' dstV + + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast _ _ dsts _ = + panic ("genCallSimpleCast: " ++ show (length dsts) ++ " dsts") + +-- Handle simple function call that only need simple type casting, of the form: +-- truncate arg >>= \a -> call(a) >>= zext +-- +-- 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. +genCallSimpleCast2 :: Width -> ForeignTarget -> [CmmFormal] -> [CmmActual] + -> LlvmM StmtData +genCallSimpleCast2 w t@(PrimTarget op) [dst] args = do + let width = widthToLlvmInt w + dstTy = cmmToLlvmType $ localRegType dst + + fname <- cmmPrimOpFunctions op + (fptr, _, top3) <- getInstrinct fname width (const width <$> args) + + dstV <- getCmmReg (CmmLocal dst) + + let (_, arg_hints) = foreignTargetHints t + let args_hints = zip args arg_hints + (argsV, stmts2, top2) <- arg_vars args_hints ([], nilOL, []) + (argsV', stmts4) <- castVars Signed $ zip argsV (const width <$> argsV) + (retV, s1) <- doExpr width $ Call StdCall fptr argsV' [] + (retVs', stmts5) <- castVars (cmmPrimOpRetValSignage op) [(retV,dstTy)] + let retV' = singletonPanic "genCallSimpleCast2" retVs' + let s2 = Store retV' dstV + + let stmts = stmts2 `appOL` stmts4 `snocOL` + s1 `appOL` stmts5 `snocOL` s2 + return (stmts, top2 ++ top3) +genCallSimpleCast2 _ _ dsts _ = + panic ("genCallSimpleCast2: " ++ show (length dsts) ++ " dsts") + +-- | Create a function pointer from a target. +getFunPtrW :: (LMString -> LlvmType) -> ForeignTarget + -> WriterT LlvmAccum LlvmM LlvmVar +getFunPtrW funTy targ = liftExprData $ getFunPtr funTy targ + +-- | Create a function pointer from a target. +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 + (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 dflags (ppr ty) ++ ")" + + (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) + return (v2, stmts `snocOL` s1, top) + + PrimTarget mop -> do + name <- cmmPrimOpFunctions mop + let fty = funTy name + getInstrinct2 name fty + +-- | Conversion of call arguments. +arg_varsW :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> WriterT LlvmAccum LlvmM [LlvmVar] +arg_varsW xs ys = do + (vars, stmts, decls) <- lift $ arg_vars xs ys + tell $ LlvmAccum stmts decls + return vars + +-- | Conversion of call arguments. +arg_vars :: [(CmmActual, ForeignHint)] + -> ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + -> LlvmM ([LlvmVar], LlvmStatements, [LlvmCmmDecl]) + +arg_vars [] (vars, stmts, tops) + = return (vars, stmts, tops) + +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 dflags (ppr a) ++ ")" + + (v2, s1) <- doExpr i8Ptr $ Cast op v1 i8Ptr + arg_vars rest (vars ++ [v2], stmts `appOL` stmts' `snocOL` s1, + 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. +castVarsW :: Signage + -> [(LlvmVar, LlvmType)] + -> WriterT LlvmAccum LlvmM [LlvmVar] +castVarsW signage vars = do + (vars, stmts) <- lift $ castVars signage vars + tell $ LlvmAccum stmts mempty + return vars + +-- | Cast a collection of LLVM variables to specific types. +castVars :: Signage -> [(LlvmVar, LlvmType)] + -> LlvmM ([LlvmVar], LlvmStatements) +castVars signage vars = do + done <- mapM (uncurry (castVar signage)) 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 :: Signage -> LlvmVar -> LlvmType -> LlvmM (LlvmVar, LlvmStatement) +castVar signage v t | getVarType v == t + = return (v, Nop) + + | otherwise + = do dflags <- getDynFlags + let op = case (getVarType v, t) of + (LMInt n, LMInt m) + -> if n < m then extend else LM_Trunc + (vt, _) | isFloat vt && isFloat t + -> if llvmWidthInBits dflags vt < llvmWidthInBits dflags t + then LM_Fpext else LM_Fptrunc + (vt, _) | isInt vt && isFloat t -> LM_Sitofp + (vt, _) | isFloat vt && isInt t -> LM_Fptosi + (vt, _) | isInt vt && isPointer t -> LM_Inttoptr + (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint + (vt, _) | isPointer vt && isPointer t -> LM_Bitcast + (vt, _) | isVector vt && isVector t -> LM_Bitcast + + (vt, _) -> panic $ "castVars: Can't cast this type (" + ++ showSDoc dflags (ppr vt) ++ ") to (" ++ showSDoc dflags (ppr t) ++ ")" + doExpr t $ Cast op v t + where extend = case signage of + Signed -> LM_Sext + Unsigned -> LM_Zext + + +cmmPrimOpRetValSignage :: CallishMachOp -> Signage +cmmPrimOpRetValSignage mop = case mop of + MO_Pdep _ -> Unsigned + MO_Pext _ -> Unsigned + _ -> Signed + +-- | Decide what C function to use to implement a CallishMachOp +cmmPrimOpFunctions :: CallishMachOp -> LlvmM LMString +cmmPrimOpFunctions mop = do + + dflags <- getDynFlags + let intrinTy1 = "p0i8.p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags) + intrinTy2 = "p0i8." ++ showSDoc dflags (ppr $ llvmWord dflags) + unsupported = panic ("cmmPrimOpFunctions: " ++ show mop + ++ " not supported here") + + return $ case mop of + MO_F32_Exp -> fsLit "expf" + MO_F32_ExpM1 -> fsLit "expm1f" + MO_F32_Log -> fsLit "logf" + MO_F32_Log1P -> fsLit "log1pf" + MO_F32_Sqrt -> fsLit "llvm.sqrt.f32" + MO_F32_Fabs -> fsLit "llvm.fabs.f32" + MO_F32_Pwr -> fsLit "llvm.pow.f32" + + MO_F32_Sin -> fsLit "llvm.sin.f32" + MO_F32_Cos -> fsLit "llvm.cos.f32" + MO_F32_Tan -> fsLit "tanf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + + MO_F32_Asinh -> fsLit "asinhf" + MO_F32_Acosh -> fsLit "acoshf" + MO_F32_Atanh -> fsLit "atanhf" + + MO_F64_Exp -> fsLit "exp" + MO_F64_ExpM1 -> fsLit "expm1" + MO_F64_Log -> fsLit "log" + MO_F64_Log1P -> fsLit "log1p" + MO_F64_Sqrt -> fsLit "llvm.sqrt.f64" + MO_F64_Fabs -> fsLit "llvm.fabs.f64" + MO_F64_Pwr -> fsLit "llvm.pow.f64" + + MO_F64_Sin -> fsLit "llvm.sin.f64" + MO_F64_Cos -> fsLit "llvm.cos.f64" + MO_F64_Tan -> fsLit "tan" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + + MO_F64_Asinh -> fsLit "asinh" + MO_F64_Acosh -> fsLit "acosh" + MO_F64_Atanh -> fsLit "atanh" + + MO_Memcpy _ -> fsLit $ "llvm.memcpy." ++ intrinTy1 + MO_Memmove _ -> fsLit $ "llvm.memmove." ++ intrinTy1 + MO_Memset _ -> fsLit $ "llvm.memset." ++ intrinTy2 + MO_Memcmp _ -> fsLit $ "memcmp" + + (MO_PopCnt w) -> fsLit $ "llvm.ctpop." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BSwap w) -> fsLit $ "llvm.bswap." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_BRev w) -> fsLit $ "llvm.bitreverse." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Clz w) -> fsLit $ "llvm.ctlz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + (MO_Ctz w) -> fsLit $ "llvm.cttz." ++ showSDoc dflags (ppr $ widthToLlvmInt w) + + (MO_Pdep w) -> let w' = showSDoc dflags (ppr $ widthInBits w) + in if isBmi2Enabled dflags + then fsLit $ "llvm.x86.bmi.pdep." ++ w' + else fsLit $ "hs_pdep" ++ w' + (MO_Pext w) -> let w' = showSDoc dflags (ppr $ widthInBits w) + in if isBmi2Enabled dflags + then fsLit $ "llvm.x86.bmi.pext." ++ w' + else fsLit $ "hs_pext" ++ w' + + (MO_Prefetch_Data _ )-> fsLit "llvm.prefetch" + + MO_AddIntC w -> fsLit $ "llvm.sadd.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_SubIntC w -> fsLit $ "llvm.ssub.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_Add2 w -> fsLit $ "llvm.uadd.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_AddWordC w -> fsLit $ "llvm.uadd.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + MO_SubWordC w -> fsLit $ "llvm.usub.with.overflow." + ++ showSDoc dflags (ppr $ widthToLlvmInt w) + + MO_S_Mul2 {} -> unsupported + MO_S_QuotRem {} -> unsupported + MO_U_QuotRem {} -> unsupported + MO_U_QuotRem2 {} -> unsupported + -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the + -- appropriate case of genCall. + MO_U_Mul2 {} -> unsupported + MO_ReadBarrier -> unsupported + MO_WriteBarrier -> unsupported + MO_Touch -> unsupported + MO_UF_Conv _ -> unsupported + + MO_AtomicRead _ -> unsupported + MO_AtomicRMW _ _ -> unsupported + MO_AtomicWrite _ -> unsupported + MO_Cmpxchg _ -> unsupported + +-- | Tail function calls +genJump :: CmmExpr -> [GlobalReg] -> LlvmM StmtData + +-- Call to known function +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 (stmts `appOL` stgStmts `snocOL` s1 `snocOL` s2, top) + + +-- Call to unknown function / address +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 dflags (ppr ty) ++ ")" + + (v1, s1) <- doExpr (pLift fty) $ Cast cast vf (pLift fty) + (stgRegs, stgStmts) <- funEpilogue live + let s2 = Expr $ Call TailCall v1 stgRegs llvmStdFunAttrs + let s3 = Return Nothing + return (stmts `snocOL` s1 `appOL` stgStmts `snocOL` s2 `snocOL` s3, + top) + + +-- | CmmAssign operation +-- +-- We use stack allocated variables for CmmReg. The optimiser will replace +-- these with registers when possible. +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 (stmts `snocOL` s1 `snocOL` s2, top2) + + LMVector _ _ -> do + (v, s1) <- doExpr ty $ Cast LM_Bitcast vval ty + let s2 = Store v vreg + return (stmts `snocOL` s1 `snocOL` s2, top2) + + _ -> do + let s1 = Store vval vreg + return (stmts `snocOL` s1, top2) + + +-- | CmmStore operation +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 addr@(CmmReg (CmmGlobal r)) val + = genStore_fast addr r 0 val + +genStore addr@(CmmRegOff (CmmGlobal r) n) val + = genStore_fast addr r n val + +genStore addr@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast addr r (fromInteger n) val + +genStore addr@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + val + = genStore_fast addr r (negate $ fromInteger n) val + +-- generic case +genStore addr val + = getTBAAMeta topN >>= genStore_slow addr val + +-- | CmmStore operation +-- This is a special case for storing to a global register pointer +-- offset such as I32[Sp+8]. +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 + (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 (stmts `appOL` s1 `snocOL` s2 + `snocOL` s3, top) + + -- cast to pointer type needed + False -> do + let ty = (pLift . getVarType) vval + (ptr', s3) <- doExpr ty $ Cast LM_Bitcast ptr ty + let s4 = MetaStmt meta $ Store vval ptr' + 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 addr val meta + + +-- | CmmStore operation +-- Generic case. Uses casts and pointer arithmetic if needed. +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 (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + LMPointer _ -> do + let s1 = MetaStmt meta $ Store vval vaddr + 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 (stmts `snocOL` s1 `snocOL` s2, top1 ++ top2) + + other -> + pprPanic "genStore: ptr not right type!" + (PprCmm.pprExpr addr <+> text ( + "Size of Ptr: " ++ show (llvmPtrBits dflags) ++ + ", Size of var: " ++ show (llvmWidthInBits dflags other) ++ + ", Var: " ++ showSDoc dflags (ppr vaddr))) + + +-- | Unconditional branch +genBranch :: BlockId -> LlvmM StmtData +genBranch id = + let label = blockIdToLlvm id + in return (unitOL $ Branch label, []) + + +-- | Conditional branch +genCondBranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> LlvmM StmtData +genCondBranch cond idT idF likely = do + let labelT = blockIdToLlvm idT + let labelF = blockIdToLlvm idF + -- See Note [Literals and branch conditions]. + (vc, stmts1, top1) <- exprToVarOpt i1Option cond + if getVarType vc == i1 + then do + (vc', (stmts2, top2)) <- case likely of + Just b -> genExpectLit (if b then 1 else 0) i1 vc + _ -> pure (vc, (nilOL, [])) + let s1 = BranchIf vc' labelT labelF + return (stmts1 `appOL` stmts2 `snocOL` s1, top1 ++ top2) + else do + dflags <- getDynFlags + panic $ "genCondBranch: Cond expr not bool! (" ++ showSDoc dflags (ppr vc) ++ ")" + + +-- | Generate call to llvm.expect.x intrinsic. Assigning result to a new var. +genExpectLit :: Integer -> LlvmType -> LlvmVar -> LlvmM (LlvmVar, StmtData) +genExpectLit expLit expTy var = do + dflags <- getDynFlags + + let + lit = LMLitVar $ LMIntLit expLit expTy + + llvmExpectName + | isInt expTy = fsLit $ "llvm.expect." ++ showSDoc dflags (ppr expTy) + | otherwise = panic $ "genExpectedLit: Type not an int!" + + (llvmExpect, stmts, top) <- + getInstrinct llvmExpectName expTy [expTy, expTy] + (var', call) <- doExpr expTy $ Call StdCall llvmExpect [var, lit] [] + return (var', (stmts `snocOL` call, top)) + +{- Note [Literals and branch conditions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is important that whenever we generate branch conditions for +literals like '1', they are properly narrowed to an LLVM expression of +type 'i1' (for bools.) Otherwise, nobody is happy. So when we convert +a CmmExpr to an LLVM expression for a branch conditional, exprToVarOpt +must be certain to return a properly narrowed type. genLit is +responsible for this, in the case of literal integers. + +Often, we won't see direct statements like: + + if(1) { + ... + } else { + ... + } + +at this point in the pipeline, because the Glorious Code Generator +will do trivial branch elimination in the sinking pass (among others,) +which will eliminate the expression entirely. + +However, it's certainly possible and reasonable for this to occur in +hand-written C-- code. Consider something like: + + #if !defined(SOME_CONDITIONAL) + #define CHECK_THING(x) 1 + #else + #define CHECK_THING(x) some_operation((x)) + #endif + + f() { + + if (CHECK_THING(xyz)) { + ... + } else { + ... + } + + } + +In such an instance, CHECK_THING might result in an *expression* in +one case, and a *literal* in the other, depending on what in +particular was #define'd. So we must be sure to properly narrow the +literal in this case to i1 as it won't be eliminated beforehand. + +For a real example of this, see ./rts/StgStdThunks.cmm + +-} + + + +-- | Switch branch +genSwitch :: CmmExpr -> SwitchTargets -> LlvmM StmtData +genSwitch cond ids = do + (vc, stmts, top) <- exprToVar cond + let ty = getVarType vc + + let labels = [ (mkIntLit ty ix, blockIdToLlvm b) + | (ix, b) <- switchTargetsCases ids ] + -- out of range is undefined, so let's just branch to first label + let defLbl | Just l <- switchTargetsDefault ids = blockIdToLlvm l + | otherwise = snd (head labels) + + let s1 = Switch vc defLbl labels + return $ (stmts `snocOL` s1, top) + + +-- ----------------------------------------------------------------------------- +-- * CmmExpr code generation +-- + +-- | An expression conversion return data: +-- * 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 = (LlvmVar, LlvmStatements, [LlvmCmmDecl]) + +-- | Values which can be passed to 'exprToVar' to configure its +-- behaviour in certain circumstances. +-- +-- Currently just used for determining if a comparison should return +-- a boolean (i1) or a word. See Note [Literals and branch conditions]. +newtype EOption = EOption { i1Expected :: Bool } +-- XXX: EOption is an ugly and inefficient solution to this problem. + +-- | i1 type expected (condition scrutinee). +i1Option :: EOption +i1Option = EOption True + +-- | Word type expected (usual). +wordOption :: EOption +wordOption = EOption False + +-- | Convert a CmmExpr to a list of LlvmStatements with the result of the +-- expression being stored in the returned LlvmVar. +exprToVar :: CmmExpr -> LlvmM ExprData +exprToVar = exprToVarOpt wordOption + +exprToVarOpt :: EOption -> CmmExpr -> LlvmM ExprData +exprToVarOpt opt e = case e of + + CmmLit lit + -> genLit opt lit + + CmmLoad e' ty + -> genLoad False e' ty + + -- Cmmreg in expression is the value, so must load. If you want actual + -- reg pointer, call getCmmReg directly. + CmmReg r -> do + (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 (v2, s1 `snocOL` s2, []) + + False -> return (v1, s1, []) + + CmmMachOp op exprs + -> genMachOp opt op exprs + + CmmRegOff r i + -> do dflags <- getDynFlags + exprToVar $ expandCmmReg dflags (r, i) + + CmmStackSlot _ _ + -> panic "exprToVar: CmmStackSlot not supported!" + + +-- | Handle CmmMachOp expressions +genMachOp :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Unary Machop +genMachOp _ op [x] = case op of + + MO_Not w -> + let all1 = mkIntLit (widthToLlvmInt w) (-1) + in negate (widthToLlvmInt w) all1 LM_MO_Xor + + MO_S_Neg w -> + let all0 = mkIntLit (widthToLlvmInt w) 0 + in negate (widthToLlvmInt w) all0 LM_MO_Sub + + MO_F_Neg w -> + let all0 = LMLitVar $ LMFloatLit (-0) (widthToLlvmFloat w) + in negate (widthToLlvmFloat w) all0 LM_MO_FSub + + MO_SF_Conv _ w -> fiConv (widthToLlvmFloat w) LM_Sitofp + MO_FS_Conv _ w -> fiConv (widthToLlvmInt w) LM_Fptosi + + MO_SS_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Sext + + MO_UU_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_XX_Conv from to + -> sameConv from (widthToLlvmInt to) LM_Trunc LM_Zext + + MO_FF_Conv from to + -> sameConv from (widthToLlvmFloat to) LM_Fptrunc LM_Fpext + + MO_VS_Neg len w -> + let ty = widthToLlvmInt w + vecty = LMVector len ty + all0 = LMIntLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_Sub + + MO_VF_Neg len w -> + let ty = widthToLlvmFloat w + vecty = LMVector len ty + all0 = LMFloatLit (-0) ty + all0s = LMLitVar $ LMVectorLit (replicate len all0) + in negateVec vecty all0s LM_MO_FSub + + MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm" + + -- Handle unsupported cases explicitly so we get a warning + -- of missing case when new MachOps added + MO_Add _ -> panicOp + MO_Mul _ -> panicOp + MO_Sub _ -> panicOp + MO_S_MulMayOflo _ -> panicOp + MO_S_Quot _ -> panicOp + MO_S_Rem _ -> panicOp + MO_U_MulMayOflo _ -> panicOp + MO_U_Quot _ -> panicOp + MO_U_Rem _ -> panicOp + + MO_Eq _ -> panicOp + MO_Ne _ -> panicOp + MO_S_Ge _ -> panicOp + MO_S_Gt _ -> panicOp + MO_S_Le _ -> panicOp + MO_S_Lt _ -> panicOp + MO_U_Ge _ -> panicOp + MO_U_Gt _ -> panicOp + MO_U_Le _ -> panicOp + MO_U_Lt _ -> panicOp + + MO_F_Add _ -> panicOp + MO_F_Sub _ -> panicOp + MO_F_Mul _ -> panicOp + MO_F_Quot _ -> panicOp + MO_F_Eq _ -> panicOp + MO_F_Ne _ -> panicOp + MO_F_Ge _ -> panicOp + MO_F_Gt _ -> panicOp + MO_F_Le _ -> panicOp + MO_F_Lt _ -> panicOp + + MO_And _ -> panicOp + MO_Or _ -> panicOp + MO_Xor _ -> panicOp + MO_Shl _ -> panicOp + MO_U_Shr _ -> panicOp + MO_S_Shr _ -> panicOp + + MO_V_Insert _ _ -> panicOp + MO_V_Extract _ _ -> panicOp + + MO_V_Add _ _ -> panicOp + MO_V_Sub _ _ -> panicOp + MO_V_Mul _ _ -> panicOp + + MO_VS_Quot _ _ -> panicOp + MO_VS_Rem _ _ -> panicOp + + MO_VU_Quot _ _ -> panicOp + MO_VU_Rem _ _ -> panicOp + + MO_VF_Insert _ _ -> panicOp + MO_VF_Extract _ _ -> panicOp + + MO_VF_Add _ _ -> panicOp + MO_VF_Sub _ _ -> panicOp + MO_VF_Mul _ _ -> panicOp + MO_VF_Quot _ _ -> panicOp + + where + negate ty v2 negOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx + return (v1, stmts `snocOL` s1, top) + + negateVec ty v2 negOp = do + (vx, stmts1, top) <- exprToVar x + (vxs', stmts2) <- castVars Signed [(vx, ty)] + let vx' = singletonPanic "genMachOp: negateVec" vxs' + (v1, s1) <- doExpr ty $ LlvmOp negOp v2 vx' + return (v1, stmts1 `appOL` stmts2 `snocOL` s1, top) + + fiConv ty convOp = do + (vx, stmts, top) <- exprToVar x + (v1, s1) <- doExpr ty $ Cast convOp vx ty + return (v1, stmts `snocOL` s1, top) + + sameConv from ty reduce expand = do + x'@(vx, stmts, top) <- exprToVar x + let sameConv' op = do + (v1, s1) <- doExpr ty $ Cast op vx ty + 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. + case widthInBits from of + w | w < toWidth -> sameConv' expand + w | w > toWidth -> sameConv' reduce + _w -> return x' + + panicOp = panic $ "LLVM.CodeGen.genMachOp: non unary op encountered" + ++ "with one argument! (" ++ show op ++ ")" + +-- Handle GlobalRegs pointers +genMachOp opt o@(MO_Add _) e@[(CmmReg (CmmGlobal r)), (CmmLit (CmmInt n _))] + = genMachOp_fast opt o r (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 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 :: 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 + (ptr, s2) <- doExpr grt $ GetElemPtr True gv [toI32 ix] + (var, s3) <- doExpr (llvmWord dflags) $ Cast LM_Ptrtoint ptr (llvmWord dflags) + return (var, s1 `snocOL` s2 `snocOL` s3, []) + + False -> genMachOp_slow opt op e + + +-- | Handle CmmMachOp expressions +-- This handles all the cases not handle by the specialised genMachOp_fast. +genMachOp_slow :: EOption -> MachOp -> [CmmExpr] -> LlvmM ExprData + +-- Element extraction +genMachOp_slow _ (MO_V_Extract l w) [val, idx] = runExprData $ do + vval <- exprToVarW val + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, LMVector l ty)] + doExprW ty $ Extract vval' vidx + where + ty = widthToLlvmInt w + +genMachOp_slow _ (MO_VF_Extract l w) [val, idx] = runExprData $ do + vval <- exprToVarW val + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, LMVector l ty)] + doExprW ty $ Extract vval' vidx + where + ty = widthToLlvmFloat w + +-- Element insertion +genMachOp_slow _ (MO_V_Insert l w) [val, elt, idx] = runExprData $ do + vval <- exprToVarW val + velt <- exprToVarW elt + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, ty)] + doExprW ty $ Insert vval' velt vidx + where + ty = LMVector l (widthToLlvmInt w) + +genMachOp_slow _ (MO_VF_Insert l w) [val, elt, idx] = runExprData $ do + vval <- exprToVarW val + velt <- exprToVarW elt + vidx <- exprToVarW idx + vval' <- singletonPanic "genMachOp_slow" <$> + castVarsW Signed [(vval, ty)] + doExprW ty $ Insert vval' velt vidx + where + ty = LMVector l (widthToLlvmFloat w) + +-- Binary MachOp +genMachOp_slow opt op [x, y] = case op of + + MO_Eq _ -> genBinComp opt LM_CMP_Eq + MO_Ne _ -> genBinComp opt LM_CMP_Ne + + MO_S_Gt _ -> genBinComp opt LM_CMP_Sgt + MO_S_Ge _ -> genBinComp opt LM_CMP_Sge + MO_S_Lt _ -> genBinComp opt LM_CMP_Slt + MO_S_Le _ -> genBinComp opt LM_CMP_Sle + + MO_U_Gt _ -> genBinComp opt LM_CMP_Ugt + MO_U_Ge _ -> genBinComp opt LM_CMP_Uge + MO_U_Lt _ -> genBinComp opt LM_CMP_Ult + MO_U_Le _ -> genBinComp opt LM_CMP_Ule + + MO_Add _ -> genBinMach LM_MO_Add + MO_Sub _ -> genBinMach LM_MO_Sub + MO_Mul _ -> genBinMach LM_MO_Mul + + MO_U_MulMayOflo _ -> panic "genMachOp: MO_U_MulMayOflo unsupported!" + + MO_S_MulMayOflo w -> isSMulOK w x y + + MO_S_Quot _ -> genBinMach LM_MO_SDiv + MO_S_Rem _ -> genBinMach LM_MO_SRem + + MO_U_Quot _ -> genBinMach LM_MO_UDiv + MO_U_Rem _ -> genBinMach LM_MO_URem + + MO_F_Eq _ -> genBinComp opt LM_CMP_Feq + MO_F_Ne _ -> genBinComp opt LM_CMP_Fne + MO_F_Gt _ -> genBinComp opt LM_CMP_Fgt + MO_F_Ge _ -> genBinComp opt LM_CMP_Fge + MO_F_Lt _ -> genBinComp opt LM_CMP_Flt + MO_F_Le _ -> genBinComp opt LM_CMP_Fle + + MO_F_Add _ -> genBinMach LM_MO_FAdd + MO_F_Sub _ -> genBinMach LM_MO_FSub + MO_F_Mul _ -> genBinMach LM_MO_FMul + MO_F_Quot _ -> genBinMach LM_MO_FDiv + + MO_And _ -> genBinMach LM_MO_And + MO_Or _ -> genBinMach LM_MO_Or + MO_Xor _ -> genBinMach LM_MO_Xor + MO_Shl _ -> genBinMach LM_MO_Shl + MO_U_Shr _ -> genBinMach LM_MO_LShr + MO_S_Shr _ -> genBinMach LM_MO_AShr + + MO_V_Add l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Add + MO_V_Sub l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Sub + MO_V_Mul l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_Mul + + MO_VS_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SDiv + MO_VS_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_SRem + + MO_VU_Quot l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_UDiv + MO_VU_Rem l w -> genCastBinMach (LMVector l (widthToLlvmInt w)) LM_MO_URem + + MO_VF_Add l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FAdd + MO_VF_Sub l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FSub + MO_VF_Mul l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FMul + MO_VF_Quot l w -> genCastBinMach (LMVector l (widthToLlvmFloat w)) LM_MO_FDiv + + MO_Not _ -> panicOp + MO_S_Neg _ -> panicOp + MO_F_Neg _ -> panicOp + + MO_SF_Conv _ _ -> panicOp + MO_FS_Conv _ _ -> panicOp + MO_SS_Conv _ _ -> panicOp + MO_UU_Conv _ _ -> panicOp + MO_XX_Conv _ _ -> panicOp + MO_FF_Conv _ _ -> panicOp + + MO_V_Insert {} -> panicOp + MO_V_Extract {} -> panicOp + + MO_VS_Neg {} -> panicOp + + MO_VF_Insert {} -> panicOp + MO_VF_Extract {} -> panicOp + + MO_VF_Neg {} -> panicOp + + MO_AlignmentCheck {} -> panicOp + + where + binLlvmOp ty binOp = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + if getVarType vx == getVarType vy + then do + doExprW (ty vx) $ binOp vx vy + + else do + -- Error. Continue anyway so we can debug the generated ll file. + dflags <- getDynFlags + let style = mkCodeStyle CStyle + toString doc = renderWithStyle dflags doc style + cmmToStr = (lines . toString . PprCmm.pprExpr) + statement $ Comment $ map fsLit $ cmmToStr x + statement $ Comment $ map fsLit $ cmmToStr y + doExprW (ty vx) $ binOp vx vy + + binCastLlvmOp ty binOp = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + vxy' <- castVarsW Signed [(vx, ty), (vy, ty)] + case vxy' of + [vx',vy'] -> doExprW ty $ binOp vx' vy' + _ -> panic "genMachOp_slow: binCastLlvmOp" + + -- | 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@(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 (v2, stmts `snocOL` s1, top) + else + panic $ "genBinComp: Compare returned type other then i1! " + ++ (showSDoc dflags $ ppr $ getVarType v1) + + genBinMach op = binLlvmOp getVarType (LlvmOp op) + + genCastBinMach ty op = binCastLlvmOp ty (LlvmOp op) + + -- | Detect if overflow will occur in signed multiply of the two + -- 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 -> LlvmM ExprData + isSMulOK _ x y = runExprData $ do + vx <- exprToVarW x + vy <- exprToVarW y + + dflags <- getDynFlags + let word = getVarType vx + let word2 = LMInt $ 2 * (llvmWidthInBits dflags $ getVarType vx) + let shift = llvmWidthInBits dflags word + let shift1 = toIWord dflags (shift - 1) + let shift2 = toIWord dflags shift + + if isInt word + then do + x1 <- doExprW word2 $ Cast LM_Sext vx word2 + y1 <- doExprW word2 $ Cast LM_Sext vy word2 + r1 <- doExprW word2 $ LlvmOp LM_MO_Mul x1 y1 + rlow1 <- doExprW word $ Cast LM_Trunc r1 word + rlow2 <- doExprW word $ LlvmOp LM_MO_AShr rlow1 shift1 + rhigh1 <- doExprW word2 $ LlvmOp LM_MO_AShr r1 shift2 + rhigh2 <- doExprW word $ Cast LM_Trunc rhigh1 word + doExprW word $ LlvmOp LM_MO_Sub rlow2 rhigh2 + + else + panic $ "isSMulOK: Not bit type! (" ++ showSDoc dflags (ppr word) ++ ")" + + panicOp = panic $ "LLVM.CodeGen.genMachOp_slow: unary op encountered" + ++ "with two arguments! (" ++ show op ++ ")" + +-- More than two expression, invalid! +genMachOp_slow _ _ _ = panic "genMachOp: More than 2 expressions in MachOp!" + + +-- | Handle CmmLoad expression. +genLoad :: Atomic -> 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 atomic e@(CmmReg (CmmGlobal r)) ty + = genLoad_fast atomic e r 0 ty + +genLoad atomic e@(CmmRegOff (CmmGlobal r) n) ty + = genLoad_fast atomic e r n ty + +genLoad atomic e@(CmmMachOp (MO_Add _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast atomic e r (fromInteger n) ty + +genLoad atomic e@(CmmMachOp (MO_Sub _) [ + (CmmReg (CmmGlobal r)), + (CmmLit (CmmInt n _))]) + ty + = genLoad_fast atomic e r (negate $ fromInteger n) ty + +-- generic case +genLoad atomic e ty + = getTBAAMeta topN >>= genLoad_slow atomic e ty + +-- | Handle CmmLoad expression. +-- This is a special case for loading from a global register pointer +-- offset such as I32[Sp+8]. +genLoad_fast :: Atomic -> CmmExpr -> GlobalReg -> Int -> CmmType + -> LlvmM ExprData +genLoad_fast atomic 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) + case isPointer grt && rem == 0 of + True -> do + (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 $ loadInstr ptr) + return (var, s1 `snocOL` s2 `snocOL` s3, + []) + + -- cast to pointer type needed + False -> do + let pty = pLift ty' + (ptr', s3) <- doExpr pty $ Cast LM_Bitcast ptr pty + (var, s4) <- doExpr ty' (MExpr meta $ loadInstr ptr') + 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 atomic e ty meta + where + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr + +-- | Handle Cmm load expression. +-- Generic case. Uses casts and pointer arithmetic if needed. +genLoad_slow :: Atomic -> CmmExpr -> CmmType -> [MetaAnnot] -> LlvmM ExprData +genLoad_slow atomic e ty meta = runExprData $ do + iptr <- exprToVarW e + dflags <- getDynFlags + case getVarType iptr of + LMPointer _ -> do + doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr iptr) + + i@(LMInt _) | i == llvmWord dflags -> do + let pty = LMPointer $ cmmToLlvmType ty + ptr <- doExprW pty $ Cast LM_Inttoptr iptr pty + doExprW (cmmToLlvmType ty) (MExpr meta $ loadInstr ptr) + + other -> do 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 + loadInstr ptr | atomic = ALoad SyncSeqCst False ptr + | otherwise = Load ptr + + +-- | 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 -> panic $ "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 panic $ "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 + var = LMLocalVar un (LMPointer ty') + alc = Alloca ty' 1 + in (var, unitOL $ Assignment var alc) + +allocReg _ = panic $ "allocReg: Global reg encountered! Global registers should" + ++ " have been handled elsewhere!" + + +-- | Generate code for a literal +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) + -- comm = Comment [ fsLit $ "EOption: " ++ show opt + -- , fsLit $ "Width : " ++ show w + -- , fsLit $ "Width' : " ++ show (widthInBits w) + -- ] + in return (mkIntLit width i, nilOL, []) + +genLit _ (CmmFloat r w) + = return (LMLitVar $ LMFloatLit (fromRational r) (widthToLlvmFloat w), + nilOL, []) + +genLit opt (CmmVec ls) + = do llvmLits <- mapM toLlvmLit ls + return (LMLitVar $ LMVectorLit llvmLits, nilOL, []) + where + toLlvmLit :: CmmLit -> LlvmM LlvmLit + toLlvmLit lit = do + (llvmLitVar, _, _) <- genLit opt lit + case llvmLitVar of + LMLitVar llvmLit -> return llvmLit + _ -> panic "genLit" + +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 (v1, stmts `snocOL` s1, stat) + +genLit opt (CmmLabelDiffOff l1 l2 off w) = 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 + if (isInt ty1) && (isInt ty2) + && (llvmWidthInBits dflags ty1 == llvmWidthInBits dflags ty2) + then do + (v1, s1) <- doExpr (getVarType vl1) $ LlvmOp LM_MO_Sub vl1 vl2 + (v2, s2) <- doExpr (getVarType v1 ) $ LlvmOp LM_MO_Add v1 voff + let ty = widthToLlvmInt w + let stmts = stmts1 `appOL` stmts2 `snocOL` s1 `snocOL` s2 + if w /= wordWidth dflags + then do + (v3, s3) <- doExpr ty $ Cast LM_Trunc v2 ty + return (v3, stmts `snocOL` s3, stat1 ++ stat2) + else + return (v2, stmts, stat1 ++ stat2) + else + panic "genLit: CmmLabelDiffOff encountered with different label ty!" + +genLit opt (CmmBlock b) + = genLit opt (CmmLabel $ infoTblLbl b) + +genLit _ CmmHighStackMark + = panic "genStaticLit - CmmHighStackMark unsupported!" + + +-- ----------------------------------------------------------------------------- +-- * Misc +-- + +-- | Find CmmRegs that get assigned and allocate them on the stack +-- +-- Any register that gets written needs to be allocated 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 unnecessarily 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 + + let getAssignedRegs :: CmmNode O O -> [CmmReg] + getAssignedRegs (CmmAssign reg _) = [reg] + getAssignedRegs (CmmUnsafeForeignCall _ rs _) = 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 `snocOL` jumpToEntry, []) + where + entryBlk : _ = cmmBlocks + jumpToEntry = Branch $ blockIdToLlvm (entryLabel entryBlk) + +-- | Function epilogue. Load STG variables to use as argument for call. +-- STG Liveness optimisation done here. +funEpilogue :: LiveGlobalRegs -> LlvmM ([LlvmVar], LlvmStatements) +funEpilogue live = do + dflags <- getDynFlags + + -- the bool indicates whether the register is padding. + let alwaysNeeded = map (\r -> (False, r)) alwaysLive + livePadded = alwaysNeeded ++ padLiveArgs dflags live + + -- Set to value or "undef" depending on whether the register is + -- actually live + 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 + let allRegs = activeStgRegs platform + loads <- flip mapM allRegs $ \r -> case () of + _ | (False, r) `elem` livePadded + -> loadExpr r -- if r is not padding, load it + | not (isFPR r) || (True, r) `elem` livePadded + -> loadUndef r + | otherwise -> return (Nothing, nilOL) + + let (vars, stmts) = unzip loads + return (catMaybes vars, concatOL stmts) + +-- | 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 :: 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 -> LlvmM LlvmVar +mkLocalVar ty = do + un <- getUniqueM + return $ LMLocalVar un ty + + +-- | Execute an expression, assigning result to a var +doExpr :: LlvmType -> LlvmExpression -> LlvmM (LlvmVar, LlvmStatement) +doExpr ty expr = do + v <- mkLocalVar ty + return (v, Assignment v expr) + + +-- | Expand CmmRegOff +expandCmmReg :: DynFlags -> (CmmReg, Int) -> CmmExpr +expandCmmReg dflags (reg, off) + = let width = typeWidth (cmmRegType dflags reg) + voff = CmmLit $ CmmInt (fromIntegral off) width + in CmmMachOp (MO_Add width) [CmmReg reg, voff] + + +-- | Convert a block id into a appropriate Llvm label +blockIdToLlvm :: BlockId -> LlvmVar +blockIdToLlvm bid = LMLocalVar (getUnique bid) LMLabel + +-- | Create Llvm int Literal +mkIntLit :: Integral a => LlvmType -> a -> LlvmVar +mkIntLit ty i = LMLitVar $ LMIntLit (toInteger i) ty + +-- | Convert int type to a LLvmVar of word or i32 size +toI32 :: Integral a => a -> LlvmVar +toI32 = mkIntLit i32 + +toIWord :: Integral a => DynFlags -> a -> LlvmVar +toIWord dflags = mkIntLit (llvmWord dflags) + + +-- | Error functions +panic :: String -> a +panic s = Outputable.panic $ "GHC.CmmToLlvm.CodeGen." ++ s + +pprPanic :: String -> SDoc -> a +pprPanic s d = Outputable.pprPanic ("GHC.CmmToLlvm.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 + + +-- | A more convenient way of accumulating LLVM statements and declarations. +data LlvmAccum = LlvmAccum LlvmStatements [LlvmCmmDecl] + +instance Semigroup LlvmAccum where + LlvmAccum stmtsA declsA <> LlvmAccum stmtsB declsB = + LlvmAccum (stmtsA Semigroup.<> stmtsB) (declsA Semigroup.<> declsB) + +instance Monoid LlvmAccum where + mempty = LlvmAccum nilOL [] + mappend = (Semigroup.<>) + +liftExprData :: LlvmM ExprData -> WriterT LlvmAccum LlvmM LlvmVar +liftExprData action = do + (var, stmts, decls) <- lift action + tell $ LlvmAccum stmts decls + return var + +statement :: LlvmStatement -> WriterT LlvmAccum LlvmM () +statement stmt = tell $ LlvmAccum (unitOL stmt) [] + +doExprW :: LlvmType -> LlvmExpression -> WriterT LlvmAccum LlvmM LlvmVar +doExprW a b = do + (var, stmt) <- lift $ doExpr a b + statement stmt + return var + +exprToVarW :: CmmExpr -> WriterT LlvmAccum LlvmM LlvmVar +exprToVarW = liftExprData . exprToVar + +runExprData :: WriterT LlvmAccum LlvmM LlvmVar -> LlvmM ExprData +runExprData action = do + (var, LlvmAccum stmts decls) <- runWriterT action + return (var, stmts, decls) + +runStmtsDecls :: WriterT LlvmAccum LlvmM () -> LlvmM (LlvmStatements, [LlvmCmmDecl]) +runStmtsDecls action = do + LlvmAccum stmts decls <- execWriterT action + return (stmts, decls) + +getCmmRegW :: CmmReg -> WriterT LlvmAccum LlvmM LlvmVar +getCmmRegW = lift . getCmmReg + +genLoadW :: Atomic -> CmmExpr -> CmmType -> WriterT LlvmAccum LlvmM LlvmVar +genLoadW atomic e ty = liftExprData $ genLoad atomic e ty + +-- | Return element of single-element list; 'panic' if list is not a single-element list +singletonPanic :: String -> [a] -> a +singletonPanic _ [x] = x +singletonPanic s _ = panic s diff --git a/compiler/GHC/CmmToLlvm/Data.hs b/compiler/GHC/CmmToLlvm/Data.hs new file mode 100644 index 0000000000..b20c9bd360 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Data.hs @@ -0,0 +1,196 @@ +{-# LANGUAGE CPP #-} +-- ---------------------------------------------------------------------------- +-- | Handle conversion of CmmData to LLVM code. +-- + +module GHC.CmmToLlvm.Data ( + genLlvmData, genData + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base + +import GHC.Cmm.BlockId +import GHC.Cmm.CLabel +import GHC.Cmm +import DynFlags +import GHC.Platform + +import FastString +import Outputable +import qualified Data.ByteString as BS + +-- ---------------------------------------------------------------------------- +-- * Constants +-- + +-- | The string appended to a variable name to create its structure type alias +structStr :: LMString +structStr = fsLit "_struct" + +-- | The LLVM visibility of the label +linkage :: CLabel -> LlvmLinkageType +linkage lbl = if externallyVisibleCLabel lbl + then ExternallyVisible else Internal + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pass a CmmStatic section to an equivalent Llvm code. +genLlvmData :: (Section, RawCmmStatics) -> LlvmM LlvmData +-- See note [emit-time elimination of static indirections] in CLabel. +genLlvmData (_, RawCmmStatics alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _]) + | lbl == mkIndStaticInfoLabel + , let labelInd (CmmLabelOff l _) = Just l + labelInd (CmmLabel l) = Just l + labelInd _ = Nothing + , Just ind' <- labelInd ind + , alias `mayRedirectTo` ind' = do + label <- strCLabel_llvm alias + label' <- strCLabel_llvm ind' + let link = linkage alias + link' = linkage ind' + -- the LLVM type we give the alias is an empty struct type + -- but it doesn't really matter, as the pointer is only + -- used for (bit/int)casting. + tyAlias = LMAlias (label `appendFS` structStr, LMStructU []) + + aliasDef = LMGlobalVar label tyAlias link Nothing Nothing Alias + -- we don't know the type of the indirectee here + indType = panic "will be filled by 'aliasify', later" + orig = LMStaticPointer $ LMGlobalVar label' indType link' Nothing Nothing Alias + + pure ([LMGlobal aliasDef $ Just orig], [tyAlias]) + +genLlvmData (sec, RawCmmStatics lbl xs) = do + label <- strCLabel_llvm lbl + static <- mapM genData xs + lmsec <- llvmSection sec + platform <- getLlvmPlatform + let types = map getStatType static + + strucTy = LMStruct types + tyAlias = LMAlias (label `appendFS` structStr, strucTy) + + struct = Just $ LMStaticStruc static tyAlias + link = linkage lbl + align = case sec of + Section CString _ -> if (platformArch platform == ArchS390X) + then Just 2 else Just 1 + _ -> Nothing + const = if isSecConstant sec then Constant else Global + varDef = LMGlobalVar label tyAlias link lmsec align const + globDef = LMGlobal varDef struct + + return ([globDef], [tyAlias]) + +-- | Format the section type part of a Cmm Section +llvmSectionType :: Platform -> SectionType -> FastString +llvmSectionType p t = case t of + Text -> fsLit ".text" + ReadOnlyData -> case platformOS p of + OSMinGW32 -> fsLit ".rdata" + _ -> fsLit ".rodata" + RelocatableReadOnlyData -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$rel.ro" + _ -> fsLit ".data.rel.ro" + ReadOnlyData16 -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$cst16" + _ -> fsLit ".rodata.cst16" + Data -> fsLit ".data" + UninitialisedData -> fsLit ".bss" + CString -> case platformOS p of + OSMinGW32 -> fsLit ".rdata$str" + _ -> fsLit ".rodata.str" + (OtherSection _) -> panic "llvmSectionType: unknown section type" + +-- | Format a Cmm Section into a LLVM section name +llvmSection :: Section -> LlvmM LMSection +llvmSection (Section t suffix) = do + dflags <- getDynFlags + let splitSect = gopt Opt_SplitSections dflags + platform = targetPlatform dflags + if not splitSect + then return Nothing + else do + lmsuffix <- strCLabel_llvm suffix + let result sep = Just (concatFS [llvmSectionType platform t + , fsLit sep, lmsuffix]) + case platformOS platform of + OSMinGW32 -> return (result "$") + _ -> return (result ".") + +-- ---------------------------------------------------------------------------- +-- * Generate static data +-- + +-- | Handle static data +genData :: CmmStatic -> LlvmM LlvmStatic + +genData (CmmString str) = do + let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) + (BS.unpack str) + ve = v ++ [LMStaticLit $ LMIntLit 0 i8] + return $ LMStaticArray ve (LMArray (length ve) i8) + +genData (CmmUninitialised bytes) + = return $ LMUninitType (LMArray bytes i8) + +genData (CmmStaticLit lit) + = genStaticLit lit + +-- | Generate Llvm code for a static literal. +-- +-- Will either generate the code or leave it unresolved if it is a 'CLabel' +-- which isn't yet known. +genStaticLit :: CmmLit -> LlvmM LlvmStatic +genStaticLit (CmmInt i w) + = return $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w)) + +genStaticLit (CmmFloat r w) + = return $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w)) + +genStaticLit (CmmVec ls) + = do sls <- mapM toLlvmLit ls + return $ LMStaticLit (LMVectorLit sls) + where + 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 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 w) = do + dflags <- getDynFlags + var1 <- genStaticLit (CmmLabel l1) + var2 <- genStaticLit (CmmLabel l2) + let var + | w == wordWidth dflags = LMSub var1 var2 + | otherwise = LMTrunc (LMSub var1 var2) (widthToLlvmInt w) + offset = LMStaticLit $ LMIntLit (toInteger off) (LMInt $ widthInBits w) + return $ LMAdd var offset + +genStaticLit (CmmBlock b) = genStaticLit $ CmmLabel $ infoTblLbl b + +genStaticLit (CmmHighStackMark) + = panic "genStaticLit: CmmHighStackMark unsupported!" diff --git a/compiler/GHC/CmmToLlvm/Mangler.hs b/compiler/GHC/CmmToLlvm/Mangler.hs new file mode 100644 index 0000000000..1cdad2009f --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Mangler.hs @@ -0,0 +1,129 @@ +-- ----------------------------------------------------------------------------- +-- | GHC LLVM Mangler +-- +-- This script processes the assembly produced by LLVM, rewriting all symbols +-- of type @function to @object. This keeps them from going through the PLT, +-- which would be bad due to tables-next-to-code. On x86_64, +-- it also rewrites AVX instructions that require alignment to their +-- unaligned counterparts, since the stack is only 16-byte aligned but these +-- instructions require 32-byte alignment. +-- + +module GHC.CmmToLlvm.Mangler ( llvmFixupAsm ) where + +import GhcPrelude + +import DynFlags ( DynFlags, targetPlatform ) +import GHC.Platform ( platformArch, Arch(..) ) +import ErrUtils ( withTiming ) +import Outputable ( text ) + +import Control.Exception +import qualified Data.ByteString.Char8 as B +import System.IO + +-- | Read in assembly file and process +llvmFixupAsm :: DynFlags -> FilePath -> FilePath -> IO () +llvmFixupAsm dflags f1 f2 = {-# SCC "llvm_mangler" #-} + withTiming dflags (text "LLVM Mangler") id $ + withBinaryFile f1 ReadMode $ \r -> withBinaryFile f2 WriteMode $ \w -> do + go r w + hClose r + hClose w + return () + where + go :: Handle -> Handle -> IO () + go r w = do + e_l <- try $ B.hGetLine r ::IO (Either IOError B.ByteString) + let writeline a = B.hPutStrLn w (rewriteLine dflags rewrites a) >> go r w + case e_l of + Right l -> writeline l + Left _ -> return () + +-- | These are the rewrites that the mangler will perform +rewrites :: [Rewrite] +rewrites = [rewriteSymType, rewriteAVX] + +type Rewrite = DynFlags -> B.ByteString -> Maybe B.ByteString + +-- | Rewrite a line of assembly source with the given rewrites, +-- taking the first rewrite that applies. +rewriteLine :: DynFlags -> [Rewrite] -> B.ByteString -> B.ByteString +rewriteLine dflags rewrites l + -- We disable .subsections_via_symbols on darwin and ios, as the llvm code + -- gen uses prefix data for the info table. This however does not prevent + -- llvm from generating .subsections_via_symbols, which in turn with + -- -dead_strip, strips the info tables, and therefore breaks ghc. + | isSubsectionsViaSymbols l = + (B.pack "## no .subsection_via_symbols for ghc. We need our info tables!") + | otherwise = + case firstJust $ map (\rewrite -> rewrite dflags rest) rewrites of + Nothing -> l + Just rewritten -> B.concat $ [symbol, B.pack "\t", rewritten] + where + isSubsectionsViaSymbols = B.isPrefixOf (B.pack ".subsections_via_symbols") + + (symbol, rest) = splitLine l + + firstJust :: [Maybe a] -> Maybe a + firstJust (Just x:_) = Just x + firstJust [] = Nothing + firstJust (_:rest) = firstJust rest + +-- | This rewrites @.type@ annotations of function symbols to @%object@. +-- This is done as the linker can relocate @%functions@ through the +-- Procedure Linking Table (PLT). This is bad since we expect that the +-- info table will appear directly before the symbol's location. In the +-- case that the PLT is used, this will be not an info table but instead +-- some random PLT garbage. +rewriteSymType :: Rewrite +rewriteSymType _ l + | isType l = Just $ rewrite '@' $ rewrite '%' l + | otherwise = Nothing + where + isType = B.isPrefixOf (B.pack ".type") + + rewrite :: Char -> B.ByteString -> B.ByteString + rewrite prefix = replaceOnce funcType objType + where + funcType = prefix `B.cons` B.pack "function" + objType = prefix `B.cons` B.pack "object" + +-- | This rewrites aligned AVX instructions to their unaligned counterparts on +-- x86-64. This is necessary because the stack is not adequately aligned for +-- aligned AVX spills, so LLVM would emit code that adjusts the stack pointer +-- and disable tail call optimization. Both would be catastrophic here so GHC +-- tells LLVM that the stack is 32-byte aligned (even though it isn't) and then +-- rewrites the instructions in the mangler. +rewriteAVX :: Rewrite +rewriteAVX dflags s + | not isX86_64 = Nothing + | isVmovdqa s = Just $ replaceOnce (B.pack "vmovdqa") (B.pack "vmovdqu") s + | isVmovap s = Just $ replaceOnce (B.pack "vmovap") (B.pack "vmovup") s + | otherwise = Nothing + where + isX86_64 = platformArch (targetPlatform dflags) == ArchX86_64 + isVmovdqa = B.isPrefixOf (B.pack "vmovdqa") + isVmovap = B.isPrefixOf (B.pack "vmovap") + +-- | @replaceOnce match replace bs@ replaces the first occurrence of the +-- substring @match@ in @bs@ with @replace@. +replaceOnce :: B.ByteString -> B.ByteString -> B.ByteString -> B.ByteString +replaceOnce matchBS replaceOnceBS = loop + where + loop :: B.ByteString -> B.ByteString + loop cts = + case B.breakSubstring matchBS cts of + (hd,tl) | B.null tl -> hd + | otherwise -> hd `B.append` replaceOnceBS `B.append` + B.drop (B.length matchBS) tl + +-- | This function splits a line of assembly code into the label and the +-- rest of the code. +splitLine :: B.ByteString -> (B.ByteString, B.ByteString) +splitLine l = (symbol, B.dropWhile isSpace rest) + where + isSpace ' ' = True + isSpace '\t' = True + isSpace _ = False + (symbol, rest) = B.span (not . isSpace) l diff --git a/compiler/GHC/CmmToLlvm/Ppr.hs b/compiler/GHC/CmmToLlvm/Ppr.hs new file mode 100644 index 0000000000..45a8285ec6 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Ppr.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE CPP #-} + +-- ---------------------------------------------------------------------------- +-- | Pretty print helpers for the LLVM Code generator. +-- +module GHC.CmmToLlvm.Ppr ( + pprLlvmCmmDecl, pprLlvmData, infoSection + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Llvm +import GHC.CmmToLlvm.Base +import GHC.CmmToLlvm.Data + +import GHC.Cmm.CLabel +import GHC.Cmm + +import FastString +import Outputable +import Unique + +-- ---------------------------------------------------------------------------- +-- * Top level +-- + +-- | Pretty print LLVM data code +pprLlvmData :: LlvmData -> SDoc +pprLlvmData (globals, types) = + let ppLlvmTys (LMAlias a) = ppLlvmAlias a + ppLlvmTys (LMFunction f) = ppLlvmFunctionDecl f + ppLlvmTys _other = empty + + types' = vcat $ map ppLlvmTys types + globals' = ppLlvmGlobals globals + in types' $+$ globals' + + +-- | Pretty print LLVM code +pprLlvmCmmDecl :: LlvmCmmDecl -> LlvmM (SDoc, [LlvmVar]) +pprLlvmCmmDecl (CmmData _ lmdata) + = return (vcat $ map pprLlvmData lmdata, []) + +pprLlvmCmmDecl (CmmProc mb_info entry_lbl live (ListGraph blks)) + = do let lbl = case mb_info of + Nothing -> entry_lbl + Just (RawCmmStatics info_lbl _) -> info_lbl + link = if externallyVisibleCLabel lbl + then ExternallyVisible + else Internal + lmblocks = map (\(BasicBlock id stmts) -> + LlvmBlock (getUnique id) stmts) blks + + funDec <- llvmFunSig live lbl link + dflags <- getDynFlags + let buildArg = fsLit . showSDoc dflags . ppPlainName + funArgs = map buildArg (llvmFunArgs dflags live) + funSect = llvmFunSection dflags (decName funDec) + + -- generate the info table + prefix <- case mb_info of + Nothing -> return Nothing + Just (RawCmmStatics _ statics) -> do + infoStatics <- mapM genData statics + let infoTy = LMStruct $ map getStatType infoStatics + return $ Just $ LMStaticStruc infoStatics infoTy + + + let fun = LlvmFunction funDec funArgs llvmStdFunAttrs funSect + prefix lmblocks + name = decName $ funcDecl fun + defName = llvmDefLabel name + funcDecl' = (funcDecl fun) { decName = defName } + fun' = fun { funcDecl = funcDecl' } + funTy = LMFunction funcDecl' + funVar = LMGlobalVar name + (LMPointer funTy) + link + Nothing + Nothing + Alias + defVar = LMGlobalVar defName + (LMPointer funTy) + (funcLinkage funcDecl') + (funcSect fun) + (funcAlign funcDecl') + Alias + alias = LMGlobal funVar + (Just $ LMBitc (LMStaticPointer defVar) + i8Ptr) + + return (ppLlvmGlobal alias $+$ ppLlvmFunction fun', []) + + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. +infoSection :: String +infoSection = "X98A__STRIP,__me" diff --git a/compiler/GHC/CmmToLlvm/Regs.hs b/compiler/GHC/CmmToLlvm/Regs.hs new file mode 100644 index 0000000000..60c27c8f44 --- /dev/null +++ b/compiler/GHC/CmmToLlvm/Regs.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE CPP #-} + +-------------------------------------------------------------------------------- +-- | Deal with Cmm registers +-- + +module GHC.CmmToLlvm.Regs ( + lmGlobalRegArg, lmGlobalRegVar, alwaysLive, + stgTBAA, baseN, stackN, heapN, rxN, topN, tbaa, getTBAA + ) where + +#include "HsVersions.h" + +import GhcPrelude + +import GHC.Llvm + +import GHC.Cmm.Expr +import DynFlags +import FastString +import Outputable ( panic ) +import Unique + +-- | Get the LlvmVar function variable storing the real register +lmGlobalRegVar :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegVar dflags = pVarLift . lmGlobalReg dflags "_Var" + +-- | Get the LlvmVar function argument storing the real register +lmGlobalRegArg :: DynFlags -> GlobalReg -> LlvmVar +lmGlobalRegArg dflags = lmGlobalReg dflags "_Arg" + +{- Need to make sure the names here can't conflict with the unique generated + names. Uniques generated names containing only base62 chars. So using say + the '_' char guarantees this. +-} +lmGlobalReg :: DynFlags -> String -> GlobalReg -> LlvmVar +lmGlobalReg dflags suf reg + = case reg of + BaseReg -> ptrGlobal $ "Base" ++ suf + Sp -> ptrGlobal $ "Sp" ++ suf + Hp -> ptrGlobal $ "Hp" ++ suf + VanillaReg 1 _ -> wordGlobal $ "R1" ++ suf + VanillaReg 2 _ -> wordGlobal $ "R2" ++ suf + VanillaReg 3 _ -> wordGlobal $ "R3" ++ suf + VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf + VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf + VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf + SpLim -> wordGlobal $ "SpLim" ++ suf + FloatReg 1 -> floatGlobal $"F1" ++ suf + FloatReg 2 -> floatGlobal $"F2" ++ suf + FloatReg 3 -> floatGlobal $"F3" ++ suf + FloatReg 4 -> floatGlobal $"F4" ++ suf + FloatReg 5 -> floatGlobal $"F5" ++ suf + FloatReg 6 -> floatGlobal $"F6" ++ suf + DoubleReg 1 -> doubleGlobal $ "D1" ++ suf + DoubleReg 2 -> doubleGlobal $ "D2" ++ suf + DoubleReg 3 -> doubleGlobal $ "D3" ++ suf + DoubleReg 4 -> doubleGlobal $ "D4" ++ suf + DoubleReg 5 -> doubleGlobal $ "D5" ++ suf + DoubleReg 6 -> doubleGlobal $ "D6" ++ suf + XmmReg 1 -> xmmGlobal $ "XMM1" ++ suf + XmmReg 2 -> xmmGlobal $ "XMM2" ++ suf + XmmReg 3 -> xmmGlobal $ "XMM3" ++ suf + XmmReg 4 -> xmmGlobal $ "XMM4" ++ suf + XmmReg 5 -> xmmGlobal $ "XMM5" ++ suf + XmmReg 6 -> xmmGlobal $ "XMM6" ++ suf + YmmReg 1 -> ymmGlobal $ "YMM1" ++ suf + YmmReg 2 -> ymmGlobal $ "YMM2" ++ suf + YmmReg 3 -> ymmGlobal $ "YMM3" ++ suf + YmmReg 4 -> ymmGlobal $ "YMM4" ++ suf + YmmReg 5 -> ymmGlobal $ "YMM5" ++ suf + YmmReg 6 -> ymmGlobal $ "YMM6" ++ suf + ZmmReg 1 -> zmmGlobal $ "ZMM1" ++ suf + ZmmReg 2 -> zmmGlobal $ "ZMM2" ++ suf + ZmmReg 3 -> zmmGlobal $ "ZMM3" ++ suf + ZmmReg 4 -> zmmGlobal $ "ZMM4" ++ suf + ZmmReg 5 -> zmmGlobal $ "ZMM5" ++ suf + ZmmReg 6 -> zmmGlobal $ "ZMM6" ++ suf + MachSp -> wordGlobal $ "MachSp" ++ suf + _other -> panic $ "GHC.CmmToLlvm.Reg: GlobalReg (" ++ (show reg) + ++ ") not supported!" + -- LongReg, HpLim, CCSS, CurrentTSO, CurrentNusery, HpAlloc + -- EagerBlackholeInfo, GCEnter1, GCFun, BaseReg, PicBaseReg + where + wordGlobal name = LMNLocalVar (fsLit name) (llvmWord dflags) + ptrGlobal name = LMNLocalVar (fsLit name) (llvmWordPtr dflags) + floatGlobal name = LMNLocalVar (fsLit name) LMFloat + doubleGlobal name = LMNLocalVar (fsLit name) LMDouble + xmmGlobal name = LMNLocalVar (fsLit name) (LMVector 4 (LMInt 32)) + ymmGlobal name = LMNLocalVar (fsLit name) (LMVector 8 (LMInt 32)) + zmmGlobal name = LMNLocalVar (fsLit name) (LMVector 16 (LMInt 32)) + +-- | A list of STG Registers that should always be considered alive +alwaysLive :: [GlobalReg] +alwaysLive = [BaseReg, Sp, Hp, SpLim, HpLim, node] + +-- | STG Type Based Alias Analysis hierarchy +stgTBAA :: [(Unique, LMString, Maybe Unique)] +stgTBAA + = [ (rootN, fsLit "root", Nothing) + , (topN, fsLit "top", Just rootN) + , (stackN, fsLit "stack", Just topN) + , (heapN, fsLit "heap", Just topN) + , (rxN, fsLit "rx", Just heapN) + , (baseN, fsLit "base", Just topN) + -- FIX: Not 100% sure if this hierarchy is complete. I think the big thing + -- is Sp is never aliased, so might want to change the hierarchy to have Sp + -- on its own branch that is never aliased (e.g never use top as a TBAA + -- node). + ] + +-- | Id values +-- The `rootN` node is the root (there can be more than one) of the TBAA +-- hierarchy and as of LLVM 4.0 should *only* be referenced by other nodes. It +-- should never occur in any LLVM instruction statement. +rootN, topN, stackN, heapN, rxN, baseN :: Unique +rootN = getUnique (fsLit "GHC.CmmToLlvm.Regs.rootN") +topN = getUnique (fsLit "GHC.CmmToLlvm.Regs.topN") +stackN = getUnique (fsLit "GHC.CmmToLlvm.Regs.stackN") +heapN = getUnique (fsLit "GHC.CmmToLlvm.Regs.heapN") +rxN = getUnique (fsLit "GHC.CmmToLlvm.Regs.rxN") +baseN = getUnique (fsLit "GHC.CmmToLlvm.Regs.baseN") + +-- | The TBAA metadata identifier +tbaa :: LMString +tbaa = fsLit "tbaa" + +-- | Get the correct TBAA metadata information for this register type +getTBAA :: GlobalReg -> Unique +getTBAA BaseReg = baseN +getTBAA Sp = stackN +getTBAA Hp = heapN +getTBAA (VanillaReg _ _) = rxN +getTBAA _ = topN -- cgit v1.2.1