Modules: Llvm (#13009)

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@.