1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
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
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
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
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
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
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
|
{-# LANGUAGE CPP #-}
-- ----------------------------------------------------------------------------
-- | Base LLVM Code Generation module
--
-- Contains functions useful through out the code generator.
--
module LlvmCodeGen.Base (
LlvmCmmDecl, LlvmBasicBlock,
LiveGlobalRegs,
LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
LlvmVersion, supportedLlvmVersion, llvmVersionStr,
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,
) where
#include "HsVersions.h"
#include "ghcautoconf.h"
import GhcPrelude
import Llvm
import LlvmCodeGen.Regs
import CLabel
import CodeGen.Platform ( activeStgRegs )
import DynFlags
import FastString
import Cmm hiding ( succ )
import CmmUtils ( regsOverlap )
import Outputable as Outp
import Platform
import UniqFM
import Unique
import BufWrite ( BufHandle )
import UniqSet
import UniqSupply
import ErrUtils
import qualified Stream
import Control.Monad (ap)
import Data.List (sort, groupBy, head)
-- ----------------------------------------------------------------------------
-- * Some Data Types
--
type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (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 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
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
--
-- | LLVM Version Number
type LlvmVersion = (Int, Int)
-- | The LLVM Version that is currently supported.
supportedLlvmVersion :: LlvmVersion
supportedLlvmVersion = sUPPORTED_LLVM_VERSION
llvmVersionStr :: LlvmVersion -> String
llvmVersionStr (major, minor) = show major ++ "." ++ show minor
-- ----------------------------------------------------------------------------
-- * Environment Handling
--
data LlvmEnv = LlvmEnv
{ envVersion :: LlvmVersion -- ^ LLVM version
, envDynFlags :: DynFlags -- ^ Dynamic flags
, envOutput :: BufHandle -- ^ Output buffer
, envUniq :: UniqSupply -- ^ Supply of 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) }
instance Functor LlvmM where
fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
return (f x, env')
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
us <- getEnv envUniq
let (us1, us2) = splitUniqSupply us
modifyEnv (\s -> s { envUniq = us2 })
return us1
getUniqueM = do
us <- getEnv envUniq
let (u,us') = takeUniqFromSupply us
modifyEnv (\s -> s { envUniq = us' })
return u
-- | 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 -> 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 = 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 -> Outp.SDoc -> LlvmM ()
dumpIfSetLlvm flag hdr doc = do
dflags <- getDynFlags
liftIO $ dumpIfSet_dyn dflags flag hdr 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" 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' = fsLit n `appendFS` fsLit "$def"
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
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
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
platform <- getLlvmPlatform
dflags <- getDynFlags
let sdoc = pprCLabel platform 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 (llvmLbl `appendFS` fsLit "$def") ty Global
-- Otherwise use a forward alias of it
Nothing -> do
saveAlias llvmLbl
return $ mkGlbVar llvmLbl i8 Alias
-- | 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]
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)
]
-- 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 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@.
|