7a673b8ec3e10891d1439d53115c2ee9c39a0cec
[ghc.git] / compiler / llvmGen / LlvmCodeGen / Base.hs
1 {-# LANGUAGE CPP #-}
2
3 -- ----------------------------------------------------------------------------
4 -- | Base LLVM Code Generation module
5 --
6 -- Contains functions useful through out the code generator.
7 --
8
9 module LlvmCodeGen.Base (
10
11 LlvmCmmDecl, LlvmBasicBlock,
12 LiveGlobalRegs,
13 LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
14
15 LlvmVersion, supportedLlvmVersion,
16
17 LlvmM,
18 runLlvm, liftStream, withClearVars, varLookup, varInsert,
19 markStackReg, checkStackReg,
20 funLookup, funInsert, getLlvmVer, getDynFlags, getDynFlag, getLlvmPlatform,
21 dumpIfSetLlvm, renderLlvm, runUs, markUsedVar, getUsedVars,
22 ghcInternalFunctions,
23
24 getMetaUniqueId,
25 setUniqMeta, getUniqMeta,
26
27 cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
28 llvmFunSig, llvmFunArgs, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
29 llvmPtrBits, tysToParams,
30
31 strCLabel_llvm, strDisplayName_llvm, strProcedureName_llvm,
32 getGlobalPtr, generateExternDecls,
33
34 aliasify,
35 ) where
36
37 #include "HsVersions.h"
38 #include "ghcautoconf.h"
39
40 import Llvm
41 import LlvmCodeGen.Regs
42
43 import CLabel
44 import CodeGen.Platform ( activeStgRegs )
45 import DynFlags
46 import FastString
47 import Cmm
48 import Outputable as Outp
49 import qualified Pretty as Prt
50 import Platform
51 import UniqFM
52 import Unique
53 import BufWrite ( BufHandle )
54 import UniqSet
55 import UniqSupply
56 import ErrUtils
57 import qualified Stream
58
59 import Control.Monad (ap)
60 #if __GLASGOW_HASKELL__ < 709
61 import Control.Applicative (Applicative(..))
62 #endif
63
64 -- ----------------------------------------------------------------------------
65 -- * Some Data Types
66 --
67
68 type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
69 type LlvmBasicBlock = GenBasicBlock LlvmStatement
70
71 -- | Global registers live on proc entry
72 type LiveGlobalRegs = [GlobalReg]
73
74 -- | Unresolved code.
75 -- Of the form: (data label, data type, unresolved data)
76 type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
77
78 -- | Top level LLVM Data (globals and type aliases)
79 type LlvmData = ([LMGlobal], [LlvmType])
80
81 -- | An unresolved Label.
82 --
83 -- Labels are unresolved when we haven't yet determined if they are defined in
84 -- the module we are currently compiling, or an external one.
85 type UnresLabel = CmmLit
86 type UnresStatic = Either UnresLabel LlvmStatic
87
88 -- ----------------------------------------------------------------------------
89 -- * Type translations
90 --
91
92 -- | Translate a basic CmmType to an LlvmType.
93 cmmToLlvmType :: CmmType -> LlvmType
94 cmmToLlvmType ty | isVecType ty = LMVector (vecLength ty) (cmmToLlvmType (vecElemType ty))
95 | isFloatType ty = widthToLlvmFloat $ typeWidth ty
96 | otherwise = widthToLlvmInt $ typeWidth ty
97
98 -- | Translate a Cmm Float Width to a LlvmType.
99 widthToLlvmFloat :: Width -> LlvmType
100 widthToLlvmFloat W32 = LMFloat
101 widthToLlvmFloat W64 = LMDouble
102 widthToLlvmFloat W80 = LMFloat80
103 widthToLlvmFloat W128 = LMFloat128
104 widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
105
106 -- | Translate a Cmm Bit Width to a LlvmType.
107 widthToLlvmInt :: Width -> LlvmType
108 widthToLlvmInt w = LMInt $ widthInBits w
109
110 -- | GHC Call Convention for LLVM
111 llvmGhcCC :: DynFlags -> LlvmCallConvention
112 llvmGhcCC dflags
113 | platformUnregisterised (targetPlatform dflags) = CC_Ccc
114 | otherwise = CC_Ghc
115
116 -- | Llvm Function type for Cmm function
117 llvmFunTy :: LiveGlobalRegs -> LlvmM LlvmType
118 llvmFunTy live = return . LMFunction =<< llvmFunSig' live (fsLit "a") ExternallyVisible
119
120 -- | Llvm Function signature
121 llvmFunSig :: LiveGlobalRegs -> CLabel -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
122 llvmFunSig live lbl link = do
123 lbl' <- strCLabel_llvm lbl
124 llvmFunSig' live lbl' link
125
126 llvmFunSig' :: LiveGlobalRegs -> LMString -> LlvmLinkageType -> LlvmM LlvmFunctionDecl
127 llvmFunSig' live lbl link
128 = do let toParams x | isPointer x = (x, [NoAlias, NoCapture])
129 | otherwise = (x, [])
130 dflags <- getDynFlags
131 return $ LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
132 (map (toParams . getVarType) (llvmFunArgs dflags live))
133 (llvmFunAlign dflags)
134
135 -- | Alignment to use for functions
136 llvmFunAlign :: DynFlags -> LMAlign
137 llvmFunAlign dflags = Just (wORD_SIZE dflags)
138
139 -- | Alignment to use for into tables
140 llvmInfAlign :: DynFlags -> LMAlign
141 llvmInfAlign dflags = Just (wORD_SIZE dflags)
142
143 -- | A Function's arguments
144 llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
145 llvmFunArgs dflags live =
146 map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
147 where platform = targetPlatform dflags
148 isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
149 isPassed r = not (isSSE r) || isLive r
150 isSSE (FloatReg _) = True
151 isSSE (DoubleReg _) = True
152 isSSE (XmmReg _) = True
153 isSSE (YmmReg _) = True
154 isSSE (ZmmReg _) = True
155 isSSE _ = False
156
157 -- | Llvm standard fun attributes
158 llvmStdFunAttrs :: [LlvmFuncAttr]
159 llvmStdFunAttrs = [NoUnwind]
160
161 -- | Convert a list of types to a list of function parameters
162 -- (each with no parameter attributes)
163 tysToParams :: [LlvmType] -> [LlvmParameter]
164 tysToParams = map (\ty -> (ty, []))
165
166 -- | Pointer width
167 llvmPtrBits :: DynFlags -> Int
168 llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
169
170 -- ----------------------------------------------------------------------------
171 -- * Llvm Version
172 --
173
174 -- | LLVM Version Number
175 type LlvmVersion = (Int, Int)
176
177 -- | The LLVM Version that is currently supported.
178 supportedLlvmVersion :: LlvmVersion
179 supportedLlvmVersion = sUPPORTED_LLVM_VERSION
180
181 -- ----------------------------------------------------------------------------
182 -- * Environment Handling
183 --
184
185 data LlvmEnv = LlvmEnv
186 { envVersion :: LlvmVersion -- ^ LLVM version
187 , envDynFlags :: DynFlags -- ^ Dynamic flags
188 , envOutput :: BufHandle -- ^ Output buffer
189 , envUniq :: UniqSupply -- ^ Supply of unique values
190 , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
191 , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
192 , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
193 , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
194 , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
195
196 -- the following get cleared for every function (see @withClearVars@)
197 , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type
198 , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
199 }
200
201 type LlvmEnvMap = UniqFM LlvmType
202
203 -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
204 newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
205
206 instance Functor LlvmM where
207 fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
208 return (f x, env')
209
210 instance Applicative LlvmM where
211 pure x = LlvmM $ \env -> return (x, env)
212 (<*>) = ap
213
214 instance Monad LlvmM where
215 return = pure
216 m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
217 runLlvmM (f x) env'
218
219 instance HasDynFlags LlvmM where
220 getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
221
222 -- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
223 liftIO :: IO a -> LlvmM a
224 liftIO m = LlvmM $ \env -> do x <- m
225 return (x, env)
226
227 -- | Get initial Llvm environment.
228 runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
229 runLlvm dflags ver out us m = do
230 _ <- runLlvmM m env
231 return ()
232 where env = LlvmEnv { envFunMap = emptyUFM
233 , envVarMap = emptyUFM
234 , envStackRegs = []
235 , envUsedVars = []
236 , envAliases = emptyUniqSet
237 , envVersion = ver
238 , envDynFlags = dflags
239 , envOutput = out
240 , envUniq = us
241 , envFreshMeta = 0
242 , envUniqMeta = emptyUFM
243 }
244
245 -- | Get environment (internal)
246 getEnv :: (LlvmEnv -> a) -> LlvmM a
247 getEnv f = LlvmM (\env -> return (f env, env))
248
249 -- | Modify environment (internal)
250 modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
251 modifyEnv f = LlvmM (\env -> return ((), f env))
252
253 -- | Lift a stream into the LlvmM monad
254 liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
255 liftStream s = Stream.Stream $ do
256 r <- liftIO $ Stream.runStream s
257 case r of
258 Left b -> return (Left b)
259 Right (a, r2) -> return (Right (a, liftStream r2))
260
261 -- | Clear variables from the environment for a subcomputation
262 withClearVars :: LlvmM a -> LlvmM a
263 withClearVars m = LlvmM $ \env -> do
264 (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
265 return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
266
267 -- | Insert variables or functions into the environment.
268 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
269 varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
270 funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
271
272 -- | Lookup variables or functions in the environment.
273 varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
274 varLookup s = getEnv (flip lookupUFM s . envVarMap)
275 funLookup s = getEnv (flip lookupUFM s . envFunMap)
276
277 -- | Set a register as allocated on the stack
278 markStackReg :: GlobalReg -> LlvmM ()
279 markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
280
281 -- | Check whether a register is allocated on the stack
282 checkStackReg :: GlobalReg -> LlvmM Bool
283 checkStackReg r = getEnv ((elem r) . envStackRegs)
284
285 -- | Allocate a new global unnamed metadata identifier
286 getMetaUniqueId :: LlvmM Int
287 getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1})
288
289 -- | Get the LLVM version we are generating code for
290 getLlvmVer :: LlvmM LlvmVersion
291 getLlvmVer = getEnv envVersion
292
293 -- | Get the platform we are generating code for
294 getDynFlag :: (DynFlags -> a) -> LlvmM a
295 getDynFlag f = getEnv (f . envDynFlags)
296
297 -- | Get the platform we are generating code for
298 getLlvmPlatform :: LlvmM Platform
299 getLlvmPlatform = getDynFlag targetPlatform
300
301 -- | Dumps the document if the corresponding flag has been set by the user
302 dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
303 dumpIfSetLlvm flag hdr doc = do
304 dflags <- getDynFlags
305 liftIO $ dumpIfSet_dyn dflags flag hdr doc
306
307 -- | Prints the given contents to the output handle
308 renderLlvm :: Outp.SDoc -> LlvmM ()
309 renderLlvm sdoc = do
310
311 -- Write to output
312 dflags <- getDynFlags
313 out <- getEnv envOutput
314 let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc
315 liftIO $ Prt.bufLeftRender out doc
316
317 -- Dump, if requested
318 dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
319 return ()
320
321 -- | Run a @UniqSM@ action with our unique supply
322 runUs :: UniqSM a -> LlvmM a
323 runUs m = LlvmM $ \env -> do
324 let (x, us') = initUs (envUniq env) m
325 return (x, env { envUniq = us' })
326
327 -- | Marks a variable as "used"
328 markUsedVar :: LlvmVar -> LlvmM ()
329 markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
330
331 -- | Return all variables marked as "used" so far
332 getUsedVars :: LlvmM [LlvmVar]
333 getUsedVars = getEnv envUsedVars
334
335 -- | Saves that at some point we didn't know the type of the label and
336 -- generated a reference to a type variable instead
337 saveAlias :: LMString -> LlvmM ()
338 saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
339
340 -- | Sets metadata node for a given unique
341 setUniqMeta :: Unique -> Int -> LlvmM ()
342 setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
343 -- | Gets metadata node for given unique
344 getUniqMeta :: Unique -> LlvmM (Maybe Int)
345 getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
346
347 -- ----------------------------------------------------------------------------
348 -- * Internal functions
349 --
350
351 -- | Here we pre-initialise some functions that are used internally by GHC
352 -- so as to make sure they have the most general type in the case that
353 -- user code also uses these functions but with a different type than GHC
354 -- internally. (Main offender is treating return type as 'void' instead of
355 -- 'void *'). Fixes trac #5486.
356 ghcInternalFunctions :: LlvmM ()
357 ghcInternalFunctions = do
358 dflags <- getDynFlags
359 mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
360 mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
361 mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
362 mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
363 where
364 mk n ret args = do
365 let n' = fsLit n `appendFS` fsLit "$def"
366 decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
367 FixedArgs (tysToParams args) Nothing
368 renderLlvm $ ppLlvmFunctionDecl decl
369 funInsert n' (LMFunction decl)
370
371 -- ----------------------------------------------------------------------------
372 -- * Label handling
373 --
374
375 -- | Pretty print a 'CLabel'.
376 strCLabel_llvm :: CLabel -> LlvmM LMString
377 strCLabel_llvm lbl = do
378 platform <- getLlvmPlatform
379 dflags <- getDynFlags
380 let sdoc = pprCLabel platform lbl
381 str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
382 return (fsLit str)
383
384 strDisplayName_llvm :: CLabel -> LlvmM LMString
385 strDisplayName_llvm lbl = do
386 platform <- getLlvmPlatform
387 dflags <- getDynFlags
388 let sdoc = pprCLabel platform lbl
389 depth = Outp.PartWay 1
390 style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
391 str = Outp.renderWithStyle dflags sdoc style
392 return (fsLit (dropInfoSuffix str))
393
394 dropInfoSuffix :: String -> String
395 dropInfoSuffix = go
396 where go "_info" = []
397 go "_static_info" = []
398 go "_con_info" = []
399 go (x:xs) = x:go xs
400 go [] = []
401
402 strProcedureName_llvm :: CLabel -> LlvmM LMString
403 strProcedureName_llvm lbl = do
404 platform <- getLlvmPlatform
405 dflags <- getDynFlags
406 let sdoc = pprCLabel platform lbl
407 depth = Outp.PartWay 1
408 style = Outp.mkUserStyle Outp.neverQualify depth
409 str = Outp.renderWithStyle dflags sdoc style
410 return (fsLit str)
411
412 -- ----------------------------------------------------------------------------
413 -- * Global variables / forward references
414 --
415
416 -- | Create/get a pointer to a global value. Might return an alias if
417 -- the value in question hasn't been defined yet. We especially make
418 -- no guarantees on the type of the returned pointer.
419 getGlobalPtr :: LMString -> LlvmM LlvmVar
420 getGlobalPtr llvmLbl = do
421 m_ty <- funLookup llvmLbl
422 let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
423 case m_ty of
424 -- Directly reference if we have seen it already
425 Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
426 -- Otherwise use a forward alias of it
427 Nothing -> do
428 saveAlias llvmLbl
429 return $ mkGlbVar llvmLbl i8 Alias
430
431 -- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
432 --
433 -- Must be called at a point where we are sure that no new global definitions
434 -- will be generated anymore!
435 generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
436 generateExternDecls = do
437 delayed <- fmap uniqSetToList $ getEnv envAliases
438 defss <- flip mapM delayed $ \lbl -> do
439 m_ty <- funLookup lbl
440 case m_ty of
441 -- If we have a definition we've already emitted the proper aliases
442 -- when the symbol itself was emitted by @aliasify@
443 Just _ -> return []
444
445 -- If we don't have a definition this is an external symbol and we
446 -- need to emit a declaration
447 Nothing ->
448 let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
449 in return [LMGlobal var Nothing]
450
451 -- Reset forward list
452 modifyEnv $ \env -> env { envAliases = emptyUniqSet }
453 return (concat defss, [])
454
455 -- | Here we take a global variable definition, rename it with a
456 -- @$def@ suffix, and generate the appropriate alias.
457 aliasify :: LMGlobal -> LlvmM [LMGlobal]
458 aliasify (LMGlobal var val) = do
459 let i8Ptr = LMPointer (LMInt 8)
460 LMGlobalVar lbl ty link sect align const = var
461
462 defLbl = lbl `appendFS` fsLit "$def"
463 defVar = LMGlobalVar defLbl ty Internal sect align const
464
465 defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
466 aliasVar = LMGlobalVar lbl (LMPointer i8Ptr) link Nothing Nothing Alias
467 aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
468
469 -- we need to mark the $def symbols as used so LLVM doesn't forget which
470 -- section they need to go in. This will vanish once we switch away from
471 -- mangling sections for TNTC.
472 markUsedVar defVar
473
474 return [ LMGlobal defVar val
475 , LMGlobal aliasVar (Just aliasVal)
476 ]
477
478 -- Note [Llvm Forward References]
479 --
480 -- The issue here is that LLVM insists on being strongly typed at
481 -- every corner, so the first time we mention something, we have to
482 -- settle what type we assign to it. That makes things awkward, as Cmm
483 -- will often reference things before their definition, and we have no
484 -- idea what (LLVM) type it is going to be before that point.
485 --
486 -- Our work-around is to define "aliases" of a standard type (i8 *) in
487 -- these kind of situations, which we later tell LLVM to be either
488 -- references to their actual local definitions (involving a cast) or
489 -- an external reference. This obviously only works for pointers.
490 --
491 -- In particular when we encounter a reference to a symbol in a chunk of
492 -- C-- there are three possible scenarios,
493 --
494 -- 1. We have already seen a definition for the referenced symbol. This
495 -- means we already know its type.
496 --
497 -- 2. We have not yet seen a definition but we will find one later in this
498 -- compilation unit. Since we want to be a good consumer of the
499 -- C-- streamed to us from upstream, we don't know the type of the
500 -- symbol at the time when we must emit the reference.
501 --
502 -- 3. We have not yet seen a definition nor will we find one in this
503 -- compilation unit. In this case the reference refers to an
504 -- external symbol for which we do not know the type.
505 --
506 -- Let's consider case (2) for a moment: say we see a reference to
507 -- the symbol @fooBar@ for which we have not seen a definition. As we
508 -- do not know the symbol's type, we assume it is of type @i8*@ and emit
509 -- the appropriate casts in @getSymbolPtr@. Later on, when we
510 -- encounter the definition of @fooBar@ we emit it but with a modified
511 -- name, @fooBar$def@ (which we'll call the definition symbol), to
512 -- since we have already had to assume that the symbol @fooBar@
513 -- is of type @i8*@. We then emit @fooBar@ itself as an alias
514 -- of @fooBar$def@ with appropriate casts. This all happens in
515 -- @aliasify@.
516 --
517 -- Case (3) is quite similar to (2): References are emitted assuming
518 -- the referenced symbol is of type @i8*@. When we arrive at the end of
519 -- the compilation unit and realize that the symbol is external, we emit
520 -- an LLVM @external global@ declaration for the symbol @fooBar@
521 -- (handled in @generateExternDecls@). This takes advantage of the
522 -- fact that the aliases produced by @aliasify@ for exported symbols
523 -- have external linkage and can therefore be used as normal symbols.
524 --
525 -- Historical note: As of release 3.5 LLVM does not allow aliases to
526 -- refer to declarations. This the reason why aliases are produced at the
527 -- point of definition instead of the point of usage, as was previously
528 -- done. See #9142 for details.
529 --
530 -- Finally, case (1) is trival. As we already have a definition for
531 -- and therefore know the type of the referenced symbol, we can do
532 -- away with casting the alias to the desired type in @getSymbolPtr@
533 -- and instead just emit a reference to the definition symbol directly.
534 -- This is the @Just@ case in @getSymbolPtr@.