diff options
Diffstat (limited to 'compiler/GHC/CmmToLlvm/Base.hs')
| -rw-r--r-- | compiler/GHC/CmmToLlvm/Base.hs | 685 |
1 files changed, 685 insertions, 0 deletions
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@. |