Base.hs 20.1 KB
Newer Older
1 2
{-# LANGUAGE CPP #-}

3 4 5 6 7 8 9 10
-- ----------------------------------------------------------------------------
-- | Base LLVM Code Generation module
--
-- Contains functions useful through out the code generator.
--

module LlvmCodeGen.Base (

Simon Peyton Jones's avatar
Simon Peyton Jones committed
11
        LlvmCmmDecl, LlvmBasicBlock,
12
        LiveGlobalRegs,
13 14
        LlvmUnresData, LlvmData, UnresLabel, UnresStatic,

15
        LlvmVersion, supportedLlvmVersion, llvmVersionStr,
16

Peter Wortmann's avatar
Peter Wortmann committed
17 18 19 20
        LlvmM,
        runLlvm, liftStream, withClearVars, varLookup, varInsert,
        markStackReg, checkStackReg,
        funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
Peter Wortmann's avatar
Peter Wortmann committed
21
        dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars,
Peter Wortmann's avatar
Peter Wortmann committed
22 23 24 25
        ghcInternalFunctions,

        getMetaUniqueId,
        setUniqMeta, getUniqMeta,
26 27

        cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
28
        llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
29
        llvmPtrBits, tysToParams, llvmFunSection,
30

Peter Wortmann's avatar
Peter Wortmann committed
31
        strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
32
        getGlobalPtr, generateExternDecls,
33

34
        aliasify,
35 36 37
    ) where

#include "HsVersions.h"
38
#include "ghcautoconf.h"
39 40 41 42 43

import Llvm
import LlvmCodeGen.Regs

import CLabel
Simon Marlow's avatar
Simon Marlow committed
44
import CodeGen.Platform ( activeStgRegs )
45
import DynFlags
46
import FastString
47
import Cmm
48
import Outputable as Outp
Peter Wortmann's avatar
Peter Wortmann committed
49
import qualified Pretty as Prt
50
import Platform
51
import UniqFM
dterei's avatar
dterei committed
52
import Unique
Peter Wortmann's avatar
Peter Wortmann committed
53 54 55 56 57
import BufWrite   ( BufHandle )
import UniqSet
import UniqSupply
import ErrUtils
import qualified Stream
58

Austin Seipp's avatar
Austin Seipp committed
59
import Control.Monad (ap)
60
#if __GLASGOW_HASKELL__ < 709
Austin Seipp's avatar
Austin Seipp committed
61
import Control.Applicative (Applicative(..))
62
#endif
Austin Seipp's avatar
Austin Seipp committed
63

64 65 66 67
-- ----------------------------------------------------------------------------
-- * Some Data Types
--

Simon Peyton Jones's avatar
Simon Peyton Jones committed
68
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
69 70
type LlvmBasicBlock = GenBasicBlock LlvmStatement

71 72 73
-- | Global registers live on proc entry
type LiveGlobalRegs = [GlobalReg]

74
-- | Unresolved code.
dterei's avatar
dterei committed
75
-- Of the form: (data label, data type, unresolved data)
76
type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
77 78 79 80 81 82 83 84

-- | 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.
dterei's avatar
dterei committed
85
type UnresLabel  = CmmLit
86 87 88 89 90 91 92 93
type UnresStatic = Either UnresLabel LlvmStatic

-- ----------------------------------------------------------------------------
-- * Type translations
--

-- | Translate a basic CmmType to an LlvmType.
cmmToLlvmType :: CmmType -> LlvmType
94 95
cmmToLlvmType ty | isVecType ty   = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
                 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
                 | otherwise      = widthToLlvmInt   $ typeWidth ty

-- | Translate a Cmm Float Width to a LlvmType.
widthToLlvmFloat :: Width -> LlvmType
widthToLlvmFloat W32  = LMFloat
widthToLlvmFloat W64  = LMDouble
widthToLlvmFloat W80  = LMFloat80
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
111 112
llvmGhcCC :: DynFlags -> LlvmCallConvention
llvmGhcCC dflags
113
 | platformUnregisterised (targetPlatform dflags) = CC_Ccc
114
 | otherwise                                      = CC_Ghc
115 116

-- | Llvm Function type for Cmm function
Peter Wortmann's avatar
Peter Wortmann committed
117 118
llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
119 120

-- | Llvm Function signature
Peter Wortmann's avatar
Peter Wortmann committed
121 122 123 124 125 126 127 128 129 130 131 132 133
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)
134

dterei's avatar
dterei committed
135
-- | Alignment to use for functions
136 137
llvmFunAlign :: DynFlags -> LMAlign
llvmFunAlign dflags = Just (wORD_SIZE dflags)
dterei's avatar
dterei committed
138 139

-- | Alignment to use for into tables
140 141
llvmInfAlign :: DynFlags -> LMAlign
llvmInfAlign dflags = Just (wORD_SIZE dflags)
142

143 144 145 146 147 148
-- | Section to use for a function
llvmFunSection :: DynFlags -> LMString -> LMSection
llvmFunSection dflags lbl
    | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
    | otherwise                     = Nothing

149
-- | A Function's arguments
150 151 152
llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
llvmFunArgs dflags live =
    map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
153
    where platform = targetPlatform dflags
154 155 156 157 158
          isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
          isPassed r = not (isSSE r) || isLive r
          isSSE (FloatReg _)  = True
          isSSE (DoubleReg _) = True
          isSSE (XmmReg _)    = True
159
          isSSE (YmmReg _)    = True
160
          isSSE (ZmmReg _)    = True
161
          isSSE _             = False
162 163 164 165 166

-- | Llvm standard fun attributes
llvmStdFunAttrs :: [LlvmFuncAttr]
llvmStdFunAttrs = [NoUnwind]

167 168 169 170 171
-- | Convert a list of types to a list of function parameters
-- (each with no parameter attributes)
tysToParams :: [LlvmType] -> [LlvmParameter]
tysToParams = map (\ty -> (ty, []))

172
-- | Pointer width
173 174
llvmPtrBits :: DynFlags -> Int
llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
175

176 177 178 179 180
-- ----------------------------------------------------------------------------
-- * Llvm Version
--

-- | LLVM Version Number
181
type LlvmVersion = (Int, Int)
182

183 184 185
-- | The LLVM Version that is currently supported.
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion = sUPPORTED_LLVM_VERSION
186

187 188 189
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr (major, minor) = show major ++ "." ++ show minor

190 191 192 193
-- ----------------------------------------------------------------------------
-- * Environment Handling
--

Peter Wortmann's avatar
Peter Wortmann committed
194
data LlvmEnv = LlvmEnv
Peter Wortmann's avatar
Peter Wortmann committed
195 196 197 198 199 200 201 202 203 204 205 206 207
  { envVersion :: LlvmVersion      -- ^ LLVM version
  , envDynFlags :: DynFlags        -- ^ Dynamic flags
  , envOutput :: BufHandle         -- ^ Output buffer
  , envUniq :: UniqSupply          -- ^ Supply of unique values
  , envFreshMeta :: Int            -- ^ Supply of fresh metadata IDs
  , envUniqMeta :: UniqFM Int      -- ^ 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)
Peter Wortmann's avatar
Peter Wortmann committed
208
  }
209

210
type LlvmEnvMap = UniqFM LlvmType
211

Peter Wortmann's avatar
Peter Wortmann committed
212 213
-- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
Austin Seipp's avatar
Austin Seipp committed
214 215 216 217 218 219

instance Functor LlvmM where
    fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
                                  return (f x, env')

instance Applicative LlvmM where
220
    pure x = LlvmM $ \env -> return (x, env)
Austin Seipp's avatar
Austin Seipp committed
221 222
    (<*>) = ap

Peter Wortmann's avatar
Peter Wortmann committed
223
instance Monad LlvmM where
224
    return = pure
Peter Wortmann's avatar
Peter Wortmann committed
225 226 227 228 229
    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)
dterei's avatar
dterei committed
230

Peter Wortmann's avatar
Peter Wortmann committed
231 232 233 234 235
-- | 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)

Peter Wortmann's avatar
Peter Wortmann committed
236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296
-- | Get initial Llvm environment.
runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
runLlvm dflags ver out us m = do
    _ <- runLlvmM m env
    return ()
  where env = LlvmEnv { envFunMap = emptyUFM
                      , envVarMap = emptyUFM
                      , envStackRegs = []
                      , envUsedVars = []
                      , envAliases = emptyUniqSet
                      , envVersion = ver
                      , envDynFlags = dflags
                      , envOutput = out
                      , envUniq = us
                      , envFreshMeta = 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 Int
getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1})
297 298

-- | Get the LLVM version we are generating code for
Peter Wortmann's avatar
Peter Wortmann committed
299 300
getLlvmVer :: LlvmM LlvmVersion
getLlvmVer = getEnv envVersion
301

Peter Wortmann's avatar
Peter Wortmann committed
302 303 304
-- | Get the platform we are generating code for
getDynFlag :: (DynFlags -> a) -> LlvmM a
getDynFlag f = getEnv (f . envDynFlags)
305 306

-- | Get the platform we are generating code for
Peter Wortmann's avatar
Peter Wortmann committed
307 308 309
getLlvmPlatform :: LlvmM Platform
getLlvmPlatform = getDynFlag targetPlatform

Peter Wortmann's avatar
Peter Wortmann committed
310 311 312 313 314 315
-- | Dumps the document if the corresponding flag has been set by the user
dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm flag hdr doc = do
  dflags <- getDynFlags
  liftIO $ dumpIfSet_dyn dflags flag hdr doc

Peter Wortmann's avatar
Peter Wortmann committed
316 317
-- | Prints the given contents to the output handle
renderLlvm :: Outp.SDoc -> LlvmM ()
Peter Wortmann's avatar
Peter Wortmann committed
318
renderLlvm sdoc = do
Peter Wortmann's avatar
Peter Wortmann committed
319 320

    -- Write to output
Peter Wortmann's avatar
Peter Wortmann committed
321 322 323 324
    dflags <- getDynFlags
    out <- getEnv envOutput
    let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc
    liftIO $ Prt.bufLeftRender out doc
Peter Wortmann's avatar
Peter Wortmann committed
325 326

    -- Dump, if requested
Peter Wortmann's avatar
Peter Wortmann committed
327 328
    dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
    return ()
Peter Wortmann's avatar
Peter Wortmann committed
329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358

-- | Run a @UniqSM@ action with our unique supply
runUs :: UniqSM a -> LlvmM a
runUs m = LlvmM $ \env -> do
    let (x, us') = initUs (envUniq env) m
    return (x, env { envUniq = us' })

-- | Marks a variable as "used"
markUsedVar :: LlvmVar -> LlvmM ()
markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }

-- | Return all variables marked as "used" so far
getUsedVars :: LlvmM [LlvmVar]
getUsedVars = getEnv envUsedVars

-- | Saves that at some point we didn't know the type of the label and
-- generated a reference to a type variable instead
saveAlias :: LMString -> LlvmM ()
saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }

-- | Sets metadata node for a given unique
setUniqMeta :: Unique -> Int -> LlvmM ()
setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
-- | Gets metadata node for given unique
getUniqMeta :: Unique -> LlvmM (Maybe Int)
getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)

-- ----------------------------------------------------------------------------
-- * Internal functions
--
359

Peter Wortmann's avatar
Peter Wortmann committed
360 361 362 363 364 365 366 367 368 369 370 371 372 373
-- | 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
374
      let n' = fsLit n `appendFS` fsLit "$def"
Peter Wortmann's avatar
Peter Wortmann committed
375 376 377 378
          decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
                                 FixedArgs (tysToParams args) Nothing
      renderLlvm $ ppLlvmFunctionDecl decl
      funInsert n' (LMFunction decl)
379 380 381 382 383 384

-- ----------------------------------------------------------------------------
-- * Label handling
--

-- | Pretty print a 'CLabel'.
Peter Wortmann's avatar
Peter Wortmann committed
385 386 387 388 389 390 391 392 393 394 395 396 397 398
strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do
    platform <- getLlvmPlatform
    dflags <- getDynFlags
    let sdoc = pprCLabel platform lbl
        str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
    return (fsLit str)

strDisplayName_llvm :: CLabel -> LlvmM LMString
strDisplayName_llvm lbl = do
    platform <- getLlvmPlatform
    dflags <- getDynFlags
    let sdoc = pprCLabel platform lbl
        depth = Outp.PartWay 1
399
        style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
Peter Wortmann's avatar
Peter Wortmann committed
400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416
        str = Outp.renderWithStyle dflags sdoc style
    return (fsLit (dropInfoSuffix str))

dropInfoSuffix :: String -> String
dropInfoSuffix = go
  where go "_info"        = []
        go "_static_info" = []
        go "_con_info"    = []
        go (x:xs)         = x:go xs
        go []             = []

strProcedureName_llvm :: CLabel -> LlvmM LMString
strProcedureName_llvm lbl = do
    platform <- getLlvmPlatform
    dflags <- getDynFlags
    let sdoc = pprCLabel platform lbl
        depth = Outp.PartWay 1
417
        style = Outp.mkUserStyle Outp.neverQualify depth
Peter Wortmann's avatar
Peter Wortmann committed
418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433
        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
434
    Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
Peter Wortmann's avatar
Peter Wortmann committed
435 436 437
    -- Otherwise use a forward alias of it
    Nothing -> do
      saveAlias llvmLbl
438
      return $ mkGlbVar llvmLbl i8 Alias
Peter Wortmann's avatar
Peter Wortmann committed
439 440 441 442 443

-- | 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!
444 445
generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
generateExternDecls = do
Peter Wortmann's avatar
Peter Wortmann committed
446 447 448 449
  delayed <- fmap uniqSetToList $ getEnv envAliases
  defss <- flip mapM delayed $ \lbl -> do
    m_ty <- funLookup lbl
    case m_ty of
450 451 452 453 454 455 456 457 458 459
      -- 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]

Peter Wortmann's avatar
Peter Wortmann committed
460 461 462 463
  -- Reset forward list
  modifyEnv $ \env -> env { envAliases = emptyUniqSet }
  return (concat defss, [])

464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486
-- | Here we take a global variable definition, rename it with a
-- @$def@ suffix, and generate the appropriate alias.
aliasify :: LMGlobal -> LlvmM [LMGlobal]
aliasify (LMGlobal var val) = do
    let i8Ptr = LMPointer (LMInt 8)
        LMGlobalVar lbl ty link sect align const = var

        defLbl = lbl `appendFS` fsLit "$def"
        defVar = LMGlobalVar defLbl ty Internal sect align const

        defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
        aliasVar = LMGlobalVar lbl (LMPointer 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)
           ]

Peter Wortmann's avatar
Peter Wortmann committed
487 488 489 490 491 492 493 494 495 496 497 498
-- 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.
499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543
--
-- 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 trival. 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@.