never executed always true always false
    1 {-# LANGUAGE CPP #-}
    2 {-# LANGUAGE DeriveFunctor #-}
    3 
    4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
    5 
    6 -- ----------------------------------------------------------------------------
    7 -- | Base LLVM Code Generation module
    8 --
    9 -- Contains functions useful through out the code generator.
   10 --
   11 
   12 module GHC.CmmToLlvm.Base (
   13 
   14         LlvmCmmDecl, LlvmBasicBlock,
   15         LiveGlobalRegs,
   16         LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
   17 
   18         LlvmVersion, supportedLlvmVersionLowerBound, supportedLlvmVersionUpperBound,
   19         llvmVersionSupported, parseLlvmVersion,
   20         llvmVersionStr, llvmVersionList,
   21 
   22         LlvmM,
   23         runLlvm, withClearVars, varLookup, varInsert,
   24         markStackReg, checkStackReg,
   25         funLookup, funInsert, getLlvmVer, getDynFlags,
   26         dumpIfSetLlvm, renderLlvm, markUsedVar, getUsedVars,
   27         ghcInternalFunctions, getPlatform, getLlvmOpts,
   28 
   29         getMetaUniqueId,
   30         setUniqMeta, getUniqMeta, liftIO,
   31 
   32         cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
   33         llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
   34         llvmPtrBits, tysToParams, llvmFunSection, padLiveArgs, isFPR,
   35 
   36         strCLabel_llvm,
   37         getGlobalPtr, generateExternDecls,
   38 
   39         aliasify, llvmDefLabel
   40     ) where
   41 
   42 #include "ghcautoconf.h"
   43 
   44 import GHC.Prelude
   45 import GHC.Utils.Panic
   46 
   47 import GHC.Llvm
   48 import GHC.CmmToLlvm.Regs
   49 
   50 import GHC.Cmm.CLabel
   51 import GHC.Cmm.Ppr.Expr ()
   52 import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
   53 import GHC.Driver.Session
   54 import GHC.Data.FastString
   55 import GHC.Cmm              hiding ( succ )
   56 import GHC.Cmm.Utils (regsOverlap)
   57 import GHC.Utils.Outputable as Outp
   58 import GHC.Platform
   59 import GHC.Types.Unique.FM
   60 import GHC.Types.Unique
   61 import GHC.Utils.BufHandle   ( BufHandle )
   62 import GHC.Types.Unique.Set
   63 import GHC.Types.Unique.Supply
   64 import GHC.Utils.Logger
   65 
   66 import Data.Maybe (fromJust)
   67 import Control.Monad (ap)
   68 import Data.Char (isDigit)
   69 import Data.List (sortBy, groupBy, intercalate)
   70 import Data.Ord (comparing)
   71 import qualified Data.List.NonEmpty as NE
   72 
   73 -- ----------------------------------------------------------------------------
   74 -- * Some Data Types
   75 --
   76 
   77 type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe RawCmmStatics) (ListGraph LlvmStatement)
   78 type LlvmBasicBlock = GenBasicBlock LlvmStatement
   79 
   80 -- | Global registers live on proc entry
   81 type LiveGlobalRegs = [GlobalReg]
   82 
   83 -- | Unresolved code.
   84 -- Of the form: (data label, data type, unresolved data)
   85 type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
   86 
   87 -- | Top level LLVM Data (globals and type aliases)
   88 type LlvmData = ([LMGlobal], [LlvmType])
   89 
   90 -- | An unresolved Label.
   91 --
   92 -- Labels are unresolved when we haven't yet determined if they are defined in
   93 -- the module we are currently compiling, or an external one.
   94 type UnresLabel  = CmmLit
   95 type UnresStatic = Either UnresLabel LlvmStatic
   96 
   97 -- ----------------------------------------------------------------------------
   98 -- * Type translations
   99 --
  100 
  101 -- | Translate a basic CmmType to an LlvmType.
  102 cmmToLlvmType :: CmmType -> LlvmType
  103 cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
  104                  | isFloatType ty = widthToLlvmFloat $ typeWidth ty
  105                  | otherwise      = widthToLlvmInt   $ typeWidth ty
  106 
  107 -- | Translate a Cmm Float Width to a LlvmType.
  108 widthToLlvmFloat :: Width -> LlvmType
  109 widthToLlvmFloat W32  = LMFloat
  110 widthToLlvmFloat W64  = LMDouble
  111 widthToLlvmFloat W128 = LMFloat128
  112 widthToLlvmFloat w    = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
  113 
  114 -- | Translate a Cmm Bit Width to a LlvmType.
  115 widthToLlvmInt :: Width -> LlvmType
  116 widthToLlvmInt w = LMInt $ widthInBits w
  117 
  118 -- | GHC Call Convention for LLVM
  119 llvmGhcCC :: Platform -> LlvmCallConvention
  120 llvmGhcCC platform
  121  | platformUnregisterised platform = CC_Ccc
  122  | otherwise                       = CC_Ghc
  123 
  124 -- | Llvm Function type for Cmm function
  125 llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
  126 llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
  127 
  128 -- | Llvm Function signature
  129 llvmFunSig :: LiveGlobalRegs ->  CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
  130 llvmFunSig live lbl link = do
  131   lbl' <- strCLabel_llvm lbl
  132   llvmFunSig' live lbl' link
  133 
  134 llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
  135 llvmFunSig' live lbl link
  136   = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
  137                       | otherwise   = (x, [])
  138        platform <- getPlatform
  139        return $ LlvmFunctionDecl lbl link (llvmGhcCC platform) LMVoid FixedArgs
  140                                  (map (toParams . getVarType) (llvmFunArgs platform live))
  141                                  (llvmFunAlign platform)
  142 
  143 -- | Alignment to use for functions
  144 llvmFunAlign :: Platform -> LMAlign
  145 llvmFunAlign platform = Just (platformWordSizeInBytes platform)
  146 
  147 -- | Alignment to use for into tables
  148 llvmInfAlign :: Platform -> LMAlign
  149 llvmInfAlign platform = Just (platformWordSizeInBytes platform)
  150 
  151 -- | Section to use for a function
  152 llvmFunSection :: LlvmOpts -> LMString -> LMSection
  153 llvmFunSection opts lbl
  154     | llvmOptsSplitSections opts = Just (concatFS [fsLit ".text.", lbl])
  155     | otherwise                  = Nothing
  156 
  157 -- | A Function's arguments
  158 llvmFunArgs :: Platform -> LiveGlobalRegs -> [LlvmVar]
  159 llvmFunArgs platform live =
  160     map (lmGlobalRegArg platform) (filter isPassed allRegs)
  161     where allRegs = activeStgRegs platform
  162           paddingRegs = padLiveArgs platform live
  163           isLive r = r `elem` alwaysLive
  164                      || r `elem` live
  165                      || r `elem` paddingRegs
  166           isPassed r = not (isFPR r) || isLive r
  167 
  168 
  169 isFPR :: GlobalReg -> Bool
  170 isFPR (FloatReg _)  = True
  171 isFPR (DoubleReg _) = True
  172 isFPR (XmmReg _)    = True
  173 isFPR (YmmReg _)    = True
  174 isFPR (ZmmReg _)    = True
  175 isFPR _             = False
  176 
  177 -- | Return a list of "padding" registers for LLVM function calls.
  178 --
  179 -- When we generate LLVM function signatures, we can't just make any register
  180 -- alive on function entry. Instead, we need to insert fake arguments of the
  181 -- same register class until we are sure that one of them is mapped to the
  182 -- register we want alive. E.g. to ensure that F5 is alive, we may need to
  183 -- insert fake arguments mapped to F1, F2, F3 and F4.
  184 --
  185 -- Invariant: Cmm FPR regs with number "n" maps to real registers with number
  186 -- "n" If the calling convention uses registers in a different order or if the
  187 -- invariant doesn't hold, this code probably won't be correct.
  188 padLiveArgs :: Platform -> LiveGlobalRegs -> LiveGlobalRegs
  189 padLiveArgs platform live =
  190       if platformUnregisterised platform
  191         then [] -- not using GHC's register convention for platform.
  192         else padded
  193   where
  194     ----------------------------------
  195     -- handle floating-point registers (FPR)
  196 
  197     fprLive = filter isFPR live  -- real live FPR registers
  198 
  199     -- we group live registers sharing the same classes, i.e. that use the same
  200     -- set of real registers to be passed. E.g. FloatReg, DoubleReg and XmmReg
  201     -- all use the same real regs on X86-64 (XMM registers).
  202     --
  203     classes         = groupBy sharesClass fprLive
  204     sharesClass a b = regsOverlap platform (norm a) (norm b) -- check if mapped to overlapping registers
  205     norm x          = CmmGlobal ((fpr_ctor x) 1)             -- get the first register of the family
  206 
  207     -- For each class, we just have to fill missing registers numbers. We use
  208     -- the constructor of the greatest register to build padding registers.
  209     --
  210     -- E.g. sortedRs = [   F2,   XMM4, D5]
  211     --      output   = [D1,   D3]
  212     padded      = concatMap padClass classes
  213     padClass rs = go sortedRs [1..]
  214       where
  215          sortedRs = sortBy (comparing fpr_num) rs
  216          maxr     = last sortedRs
  217          ctor     = fpr_ctor maxr
  218 
  219          go [] _ = []
  220          go (c1:c2:_) _   -- detect bogus case (see #17920)
  221             | fpr_num c1 == fpr_num c2
  222             , Just real <- globalRegMaybe platform c1
  223             = sorryDoc "LLVM code generator" $
  224                text "Found two different Cmm registers (" <> ppr c1 <> text "," <> ppr c2 <>
  225                text ") both alive AND mapped to the same real register: " <> ppr real <>
  226                text ". This isn't currently supported by the LLVM backend."
  227          go (c:cs) (f:fs)
  228             | fpr_num c == f = go cs fs              -- already covered by a real register
  229             | otherwise      = ctor f : go (c:cs) fs -- add padding register
  230          go _ _ = undefined -- unreachable
  231 
  232     fpr_ctor :: GlobalReg -> Int -> GlobalReg
  233     fpr_ctor (FloatReg _)  = FloatReg
  234     fpr_ctor (DoubleReg _) = DoubleReg
  235     fpr_ctor (XmmReg _)    = XmmReg
  236     fpr_ctor (YmmReg _)    = YmmReg
  237     fpr_ctor (ZmmReg _)    = ZmmReg
  238     fpr_ctor _ = error "fpr_ctor expected only FPR regs"
  239 
  240     fpr_num :: GlobalReg -> Int
  241     fpr_num (FloatReg i)  = i
  242     fpr_num (DoubleReg i) = i
  243     fpr_num (XmmReg i)    = i
  244     fpr_num (YmmReg i)    = i
  245     fpr_num (ZmmReg i)    = i
  246     fpr_num _ = error "fpr_num expected only FPR regs"
  247 
  248 
  249 -- | Llvm standard fun attributes
  250 llvmStdFunAttrs :: [LlvmFuncAttr]
  251 llvmStdFunAttrs = [NoUnwind]
  252 
  253 -- | Convert a list of types to a list of function parameters
  254 -- (each with no parameter attributes)
  255 tysToParams :: [LlvmType] -> [LlvmParameter]
  256 tysToParams = map (\ty -> (ty, []))
  257 
  258 -- | Pointer width
  259 llvmPtrBits :: Platform -> Int
  260 llvmPtrBits platform = widthInBits $ typeWidth $ gcWord platform
  261 
  262 -- ----------------------------------------------------------------------------
  263 -- * Llvm Version
  264 --
  265 
  266 newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }
  267   deriving (Eq, Ord)
  268 
  269 parseLlvmVersion :: String -> Maybe LlvmVersion
  270 parseLlvmVersion =
  271     fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)
  272   where
  273     go vs s
  274       | null ver_str
  275       = reverse vs
  276       | '.' : rest' <- rest
  277       = go (read ver_str : vs) rest'
  278       | otherwise
  279       = reverse (read ver_str : vs)
  280       where
  281         (ver_str, rest) = span isDigit s
  282 
  283 -- | The (inclusive) lower bound on the LLVM Version that is currently supported.
  284 supportedLlvmVersionLowerBound :: LlvmVersion
  285 supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])
  286 
  287 -- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.
  288 supportedLlvmVersionUpperBound :: LlvmVersion
  289 supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])
  290 
  291 llvmVersionSupported :: LlvmVersion -> Bool
  292 llvmVersionSupported v =
  293   v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound
  294 
  295 llvmVersionStr :: LlvmVersion -> String
  296 llvmVersionStr = intercalate "." . map show . llvmVersionList
  297 
  298 llvmVersionList :: LlvmVersion -> [Int]
  299 llvmVersionList = NE.toList . llvmVersionNE
  300 
  301 -- ----------------------------------------------------------------------------
  302 -- * Environment Handling
  303 --
  304 
  305 data LlvmEnv = LlvmEnv
  306   { envVersion :: LlvmVersion      -- ^ LLVM version
  307   , envOpts    :: LlvmOpts         -- ^ LLVM backend options
  308   , envDynFlags :: DynFlags        -- ^ Dynamic flags
  309   , envLogger :: !Logger           -- ^ Logger
  310   , envOutput :: BufHandle         -- ^ Output buffer
  311   , envMask :: !Char               -- ^ Mask for creating unique values
  312   , envFreshMeta :: MetaId         -- ^ Supply of fresh metadata IDs
  313   , envUniqMeta :: UniqFM Unique MetaId   -- ^ Global metadata nodes
  314   , envFunMap :: LlvmEnvMap        -- ^ Global functions so far, with type
  315   , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
  316   , envUsedVars :: [LlvmVar]       -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
  317 
  318     -- the following get cleared for every function (see @withClearVars@)
  319   , envVarMap :: LlvmEnvMap        -- ^ Local variables so far, with type
  320   , envStackRegs :: [GlobalReg]    -- ^ Non-constant registers (alloca'd in the function prelude)
  321   }
  322 
  323 type LlvmEnvMap = UniqFM Unique LlvmType
  324 
  325 -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
  326 newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
  327     deriving (Functor)
  328 
  329 instance Applicative LlvmM where
  330     pure x = LlvmM $ \env -> return (x, env)
  331     (<*>) = ap
  332 
  333 instance Monad LlvmM where
  334     m >>= f  = LlvmM $ \env -> do (x, env') <- runLlvmM m env
  335                                   runLlvmM (f x) env'
  336 
  337 instance HasDynFlags LlvmM where
  338     getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
  339 
  340 instance HasLogger LlvmM where
  341     getLogger = LlvmM $ \env -> return (envLogger env, env)
  342 
  343 
  344 -- | Get target platform
  345 getPlatform :: LlvmM Platform
  346 getPlatform = llvmOptsPlatform <$> getLlvmOpts
  347 
  348 -- | Get LLVM options
  349 getLlvmOpts :: LlvmM LlvmOpts
  350 getLlvmOpts = LlvmM $ \env -> return (envOpts env, env)
  351 
  352 instance MonadUnique LlvmM where
  353     getUniqueSupplyM = do
  354         mask <- getEnv envMask
  355         liftIO $! mkSplitUniqSupply mask
  356 
  357     getUniqueM = do
  358         mask <- getEnv envMask
  359         liftIO $! uniqFromMask mask
  360 
  361 -- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
  362 liftIO :: IO a -> LlvmM a
  363 liftIO m = LlvmM $ \env -> do x <- m
  364                               return (x, env)
  365 
  366 -- | Get initial Llvm environment.
  367 runLlvm :: Logger -> DynFlags -> LlvmVersion -> BufHandle -> LlvmM a -> IO a
  368 runLlvm logger dflags ver out m = do
  369     (a, _) <- runLlvmM m env
  370     return a
  371   where env = LlvmEnv { envFunMap = emptyUFM
  372                       , envVarMap = emptyUFM
  373                       , envStackRegs = []
  374                       , envUsedVars = []
  375                       , envAliases = emptyUniqSet
  376                       , envVersion = ver
  377                       , envOpts = initLlvmOpts dflags
  378                       , envDynFlags = dflags
  379                       , envLogger = logger
  380                       , envOutput = out
  381                       , envMask = 'n'
  382                       , envFreshMeta = MetaId 0
  383                       , envUniqMeta = emptyUFM
  384                       }
  385 
  386 -- | Get environment (internal)
  387 getEnv :: (LlvmEnv -> a) -> LlvmM a
  388 getEnv f = LlvmM (\env -> return (f env, env))
  389 
  390 -- | Modify environment (internal)
  391 modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
  392 modifyEnv f = LlvmM (\env -> return ((), f env))
  393 
  394 -- | Clear variables from the environment for a subcomputation
  395 withClearVars :: LlvmM a -> LlvmM a
  396 withClearVars m = LlvmM $ \env -> do
  397     (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
  398     return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
  399 
  400 -- | Insert variables or functions into the environment.
  401 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
  402 varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) (getUnique s) t }
  403 funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) (getUnique s) t }
  404 
  405 -- | Lookup variables or functions in the environment.
  406 varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
  407 varLookup s = getEnv (flip lookupUFM (getUnique s) . envVarMap)
  408 funLookup s = getEnv (flip lookupUFM (getUnique s) . envFunMap)
  409 
  410 -- | Set a register as allocated on the stack
  411 markStackReg :: GlobalReg -> LlvmM ()
  412 markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
  413 
  414 -- | Check whether a register is allocated on the stack
  415 checkStackReg :: GlobalReg -> LlvmM Bool
  416 checkStackReg r = getEnv ((elem r) . envStackRegs)
  417 
  418 -- | Allocate a new global unnamed metadata identifier
  419 getMetaUniqueId :: LlvmM MetaId
  420 getMetaUniqueId = LlvmM $ \env ->
  421     return (envFreshMeta env, env { envFreshMeta = succ $ envFreshMeta env })
  422 
  423 -- | Get the LLVM version we are generating code for
  424 getLlvmVer :: LlvmM LlvmVersion
  425 getLlvmVer = getEnv envVersion
  426 
  427 -- | Dumps the document if the corresponding flag has been set by the user
  428 dumpIfSetLlvm :: DumpFlag -> String -> DumpFormat -> Outp.SDoc -> LlvmM ()
  429 dumpIfSetLlvm flag hdr fmt doc = do
  430   logger <- getLogger
  431   liftIO $ putDumpFileMaybe logger flag hdr fmt doc
  432 
  433 -- | Prints the given contents to the output handle
  434 renderLlvm :: Outp.SDoc -> LlvmM ()
  435 renderLlvm sdoc = do
  436 
  437     -- Write to output
  438     dflags <- getDynFlags
  439     out <- getEnv envOutput
  440     let ctx = initSDocContext dflags (Outp.PprCode Outp.CStyle)
  441     liftIO $ Outp.bufLeftRenderSDoc ctx out sdoc
  442 
  443     -- Dump, if requested
  444     dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" FormatLLVM sdoc
  445     return ()
  446 
  447 -- | Marks a variable as "used"
  448 markUsedVar :: LlvmVar -> LlvmM ()
  449 markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
  450 
  451 -- | Return all variables marked as "used" so far
  452 getUsedVars :: LlvmM [LlvmVar]
  453 getUsedVars = getEnv envUsedVars
  454 
  455 -- | Saves that at some point we didn't know the type of the label and
  456 -- generated a reference to a type variable instead
  457 saveAlias :: LMString -> LlvmM ()
  458 saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
  459 
  460 -- | Sets metadata node for a given unique
  461 setUniqMeta :: Unique -> MetaId -> LlvmM ()
  462 setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
  463 
  464 -- | Gets metadata node for given unique
  465 getUniqMeta :: Unique -> LlvmM (Maybe MetaId)
  466 getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
  467 
  468 -- ----------------------------------------------------------------------------
  469 -- * Internal functions
  470 --
  471 
  472 -- | Here we pre-initialise some functions that are used internally by GHC
  473 -- so as to make sure they have the most general type in the case that
  474 -- user code also uses these functions but with a different type than GHC
  475 -- internally. (Main offender is treating return type as 'void' instead of
  476 -- 'void *'). Fixes trac #5486.
  477 ghcInternalFunctions :: LlvmM ()
  478 ghcInternalFunctions = do
  479     platform <- getPlatform
  480     let w = llvmWord platform
  481         cint = LMInt $ widthInBits $ cIntWidth platform
  482     mk "memcmp" cint [i8Ptr, i8Ptr, w]
  483     mk "memcpy" i8Ptr [i8Ptr, i8Ptr, w]
  484     mk "memmove" i8Ptr [i8Ptr, i8Ptr, w]
  485     mk "memset" i8Ptr [i8Ptr, w, w]
  486     mk "newSpark" w [i8Ptr, i8Ptr]
  487   where
  488     mk n ret args = do
  489       let n' = fsLit n
  490           decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
  491                                  FixedArgs (tysToParams args) Nothing
  492       renderLlvm $ ppLlvmFunctionDecl decl
  493       funInsert n' (LMFunction decl)
  494 
  495 -- ----------------------------------------------------------------------------
  496 -- * Label handling
  497 --
  498 
  499 -- | Pretty print a 'CLabel'.
  500 strCLabel_llvm :: CLabel -> LlvmM LMString
  501 strCLabel_llvm lbl = do
  502     dflags <- getDynFlags
  503     platform <- getPlatform
  504     let sdoc = pprCLabel platform CStyle lbl
  505         str = Outp.renderWithContext
  506                   (initSDocContext dflags (Outp.PprCode Outp.CStyle))
  507                   sdoc
  508     return (fsLit str)
  509 
  510 -- ----------------------------------------------------------------------------
  511 -- * Global variables / forward references
  512 --
  513 
  514 -- | Create/get a pointer to a global value. Might return an alias if
  515 -- the value in question hasn't been defined yet. We especially make
  516 -- no guarantees on the type of the returned pointer.
  517 getGlobalPtr :: LMString -> LlvmM LlvmVar
  518 getGlobalPtr llvmLbl = do
  519   m_ty <- funLookup llvmLbl
  520   let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
  521   case m_ty of
  522     -- Directly reference if we have seen it already
  523     Just ty -> do
  524       if llvmLbl `elem` (map fsLit ["newSpark", "memmove", "memcpy", "memcmp", "memset"])
  525         then return $ mkGlbVar (llvmLbl) ty Global
  526         else return $ mkGlbVar (llvmDefLabel llvmLbl) ty Global
  527     -- Otherwise use a forward alias of it
  528     Nothing -> do
  529       saveAlias llvmLbl
  530       return $ mkGlbVar llvmLbl i8 Alias
  531 
  532 -- | Derive the definition label. It has an identified
  533 -- structure type.
  534 llvmDefLabel :: LMString -> LMString
  535 llvmDefLabel = (`appendFS` fsLit "$def")
  536 
  537 -- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
  538 --
  539 -- Must be called at a point where we are sure that no new global definitions
  540 -- will be generated anymore!
  541 generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
  542 generateExternDecls = do
  543   delayed <- fmap nonDetEltsUniqSet $ getEnv envAliases
  544   -- This is non-deterministic but we do not
  545   -- currently support deterministic code-generation.
  546   -- See Note [Unique Determinism and code generation]
  547   defss <- flip mapM delayed $ \lbl -> do
  548     m_ty <- funLookup lbl
  549     case m_ty of
  550       -- If we have a definition we've already emitted the proper aliases
  551       -- when the symbol itself was emitted by @aliasify@
  552       Just _ -> return []
  553 
  554       -- If we don't have a definition this is an external symbol and we
  555       -- need to emit a declaration
  556       Nothing ->
  557         let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
  558         in return [LMGlobal var Nothing]
  559 
  560   -- Reset forward list
  561   modifyEnv $ \env -> env { envAliases = emptyUniqSet }
  562   return (concat defss, [])
  563 
  564 -- | Here we take a global variable definition, rename it with a
  565 -- @$def@ suffix, and generate the appropriate alias.
  566 aliasify :: LMGlobal -> LlvmM [LMGlobal]
  567 -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
  568 -- Here we obtain the indirectee's precise type and introduce
  569 -- fresh aliases to both the precise typed label (lbl$def) and the i8*
  570 -- typed (regular) label of it with the matching new names.
  571 aliasify (LMGlobal (LMGlobalVar lbl ty@LMAlias{} link sect align Alias)
  572                    (Just orig)) = do
  573     let defLbl = llvmDefLabel lbl
  574         LMStaticPointer (LMGlobalVar origLbl _ oLnk Nothing Nothing Alias) = orig
  575         defOrigLbl = llvmDefLabel origLbl
  576         orig' = LMStaticPointer (LMGlobalVar origLbl i8Ptr oLnk Nothing Nothing Alias)
  577     origType <- funLookup origLbl
  578     let defOrig = LMBitc (LMStaticPointer (LMGlobalVar defOrigLbl
  579                                            (pLift $ fromJust origType) oLnk
  580                                            Nothing Nothing Alias))
  581                          (pLift ty)
  582     pure [ LMGlobal (LMGlobalVar defLbl ty link sect align Alias) (Just defOrig)
  583          , LMGlobal (LMGlobalVar lbl i8Ptr link sect align Alias) (Just orig')
  584          ]
  585 aliasify (LMGlobal var val) = do
  586     let LMGlobalVar lbl ty link sect align const = var
  587 
  588         defLbl = llvmDefLabel lbl
  589         defVar = LMGlobalVar defLbl ty Internal sect align const
  590 
  591         defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
  592         aliasVar = LMGlobalVar lbl i8Ptr link Nothing Nothing Alias
  593         aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
  594 
  595     -- we need to mark the $def symbols as used so LLVM doesn't forget which
  596     -- section they need to go in. This will vanish once we switch away from
  597     -- mangling sections for TNTC.
  598     markUsedVar defVar
  599 
  600     return [ LMGlobal defVar val
  601            , LMGlobal aliasVar (Just aliasVal)
  602            ]
  603 
  604 -- Note [Llvm Forward References]
  605 --
  606 -- The issue here is that LLVM insists on being strongly typed at
  607 -- every corner, so the first time we mention something, we have to
  608 -- settle what type we assign to it. That makes things awkward, as Cmm
  609 -- will often reference things before their definition, and we have no
  610 -- idea what (LLVM) type it is going to be before that point.
  611 --
  612 -- Our work-around is to define "aliases" of a standard type (i8 *) in
  613 -- these kind of situations, which we later tell LLVM to be either
  614 -- references to their actual local definitions (involving a cast) or
  615 -- an external reference. This obviously only works for pointers.
  616 --
  617 -- In particular when we encounter a reference to a symbol in a chunk of
  618 -- C-- there are three possible scenarios,
  619 --
  620 --   1. We have already seen a definition for the referenced symbol. This
  621 --      means we already know its type.
  622 --
  623 --   2. We have not yet seen a definition but we will find one later in this
  624 --      compilation unit. Since we want to be a good consumer of the
  625 --      C-- streamed to us from upstream, we don't know the type of the
  626 --      symbol at the time when we must emit the reference.
  627 --
  628 --   3. We have not yet seen a definition nor will we find one in this
  629 --      compilation unit. In this case the reference refers to an
  630 --      external symbol for which we do not know the type.
  631 --
  632 -- Let's consider case (2) for a moment: say we see a reference to
  633 -- the symbol @fooBar@ for which we have not seen a definition. As we
  634 -- do not know the symbol's type, we assume it is of type @i8*@ and emit
  635 -- the appropriate casts in @getSymbolPtr@. Later on, when we
  636 -- encounter the definition of @fooBar@ we emit it but with a modified
  637 -- name, @fooBar$def@ (which we'll call the definition symbol), to
  638 -- since we have already had to assume that the symbol @fooBar@
  639 -- is of type @i8*@. We then emit @fooBar@ itself as an alias
  640 -- of @fooBar$def@ with appropriate casts. This all happens in
  641 -- @aliasify@.
  642 --
  643 -- Case (3) is quite similar to (2): References are emitted assuming
  644 -- the referenced symbol is of type @i8*@. When we arrive at the end of
  645 -- the compilation unit and realize that the symbol is external, we emit
  646 -- an LLVM @external global@ declaration for the symbol @fooBar@
  647 -- (handled in @generateExternDecls@). This takes advantage of the
  648 -- fact that the aliases produced by @aliasify@ for exported symbols
  649 -- have external linkage and can therefore be used as normal symbols.
  650 --
  651 -- Historical note: As of release 3.5 LLVM does not allow aliases to
  652 -- refer to declarations. This the reason why aliases are produced at the
  653 -- point of definition instead of the point of usage, as was previously
  654 -- done. See #9142 for details.
  655 --
  656 -- Finally, case (1) is trivial. As we already have a definition for
  657 -- and therefore know the type of the referenced symbol, we can do
  658 -- away with casting the alias to the desired type in @getSymbolPtr@
  659 -- and instead just emit a reference to the definition symbol directly.
  660 -- This is the @Just@ case in @getSymbolPtr@.