Implement function-sections for Haskell code, #8405
[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, llvmFunSection,
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 -- | Section to use for a function
144 llvmFunSection :: DynFlags -> LMString -> LMSection
145 llvmFunSection dflags lbl
146 | gopt Opt_SplitSections dflags = Just (concatFS [fsLit ".text.", lbl])
147 | otherwise = Nothing
148
149 -- | A Function's arguments
150 llvmFunArgs :: DynFlags -> LiveGlobalRegs -> [LlvmVar]
151 llvmFunArgs dflags live =
152 map (lmGlobalRegArg dflags) (filter isPassed (activeStgRegs platform))
153 where platform = targetPlatform dflags
154 isLive r = not (isSSE r) || r `elem` alwaysLive || r `elem` live
155 isPassed r = not (isSSE r) || isLive r
156 isSSE (FloatReg _) = True
157 isSSE (DoubleReg _) = True
158 isSSE (XmmReg _) = True
159 isSSE (YmmReg _) = True
160 isSSE (ZmmReg _) = True
161 isSSE _ = False
162
163 -- | Llvm standard fun attributes
164 llvmStdFunAttrs :: [LlvmFuncAttr]
165 llvmStdFunAttrs = [NoUnwind]
166
167 -- | Convert a list of types to a list of function parameters
168 -- (each with no parameter attributes)
169 tysToParams :: [LlvmType] -> [LlvmParameter]
170 tysToParams = map (\ty -> (ty, []))
171
172 -- | Pointer width
173 llvmPtrBits :: DynFlags -> Int
174 llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
175
176 -- ----------------------------------------------------------------------------
177 -- * Llvm Version
178 --
179
180 -- | LLVM Version Number
181 type LlvmVersion = (Int, Int)
182
183 -- | The LLVM Version that is currently supported.
184 supportedLlvmVersion :: LlvmVersion
185 supportedLlvmVersion = sUPPORTED_LLVM_VERSION
186
187 -- ----------------------------------------------------------------------------
188 -- * Environment Handling
189 --
190
191 data LlvmEnv = LlvmEnv
192 { envVersion :: LlvmVersion -- ^ LLVM version
193 , envDynFlags :: DynFlags -- ^ Dynamic flags
194 , envOutput :: BufHandle -- ^ Output buffer
195 , envUniq :: UniqSupply -- ^ Supply of unique values
196 , envFreshMeta :: Int -- ^ Supply of fresh metadata IDs
197 , envUniqMeta :: UniqFM Int -- ^ Global metadata nodes
198 , envFunMap :: LlvmEnvMap -- ^ Global functions so far, with type
199 , envAliases :: UniqSet LMString -- ^ Globals that we had to alias, see [Llvm Forward References]
200 , envUsedVars :: [LlvmVar] -- ^ Pointers to be added to llvm.used (see @cmmUsedLlvmGens@)
201
202 -- the following get cleared for every function (see @withClearVars@)
203 , envVarMap :: LlvmEnvMap -- ^ Local variables so far, with type
204 , envStackRegs :: [GlobalReg] -- ^ Non-constant registers (alloca'd in the function prelude)
205 }
206
207 type LlvmEnvMap = UniqFM LlvmType
208
209 -- | The Llvm monad. Wraps @LlvmEnv@ state as well as the @IO@ monad
210 newtype LlvmM a = LlvmM { runLlvmM :: LlvmEnv -> IO (a, LlvmEnv) }
211
212 instance Functor LlvmM where
213 fmap f m = LlvmM $ \env -> do (x, env') <- runLlvmM m env
214 return (f x, env')
215
216 instance Applicative LlvmM where
217 pure x = LlvmM $ \env -> return (x, env)
218 (<*>) = ap
219
220 instance Monad LlvmM where
221 return = pure
222 m >>= f = LlvmM $ \env -> do (x, env') <- runLlvmM m env
223 runLlvmM (f x) env'
224
225 instance HasDynFlags LlvmM where
226 getDynFlags = LlvmM $ \env -> return (envDynFlags env, env)
227
228 -- | Lifting of IO actions. Not exported, as we want to encapsulate IO.
229 liftIO :: IO a -> LlvmM a
230 liftIO m = LlvmM $ \env -> do x <- m
231 return (x, env)
232
233 -- | Get initial Llvm environment.
234 runLlvm :: DynFlags -> LlvmVersion -> BufHandle -> UniqSupply -> LlvmM () -> IO ()
235 runLlvm dflags ver out us m = do
236 _ <- runLlvmM m env
237 return ()
238 where env = LlvmEnv { envFunMap = emptyUFM
239 , envVarMap = emptyUFM
240 , envStackRegs = []
241 , envUsedVars = []
242 , envAliases = emptyUniqSet
243 , envVersion = ver
244 , envDynFlags = dflags
245 , envOutput = out
246 , envUniq = us
247 , envFreshMeta = 0
248 , envUniqMeta = emptyUFM
249 }
250
251 -- | Get environment (internal)
252 getEnv :: (LlvmEnv -> a) -> LlvmM a
253 getEnv f = LlvmM (\env -> return (f env, env))
254
255 -- | Modify environment (internal)
256 modifyEnv :: (LlvmEnv -> LlvmEnv) -> LlvmM ()
257 modifyEnv f = LlvmM (\env -> return ((), f env))
258
259 -- | Lift a stream into the LlvmM monad
260 liftStream :: Stream.Stream IO a x -> Stream.Stream LlvmM a x
261 liftStream s = Stream.Stream $ do
262 r <- liftIO $ Stream.runStream s
263 case r of
264 Left b -> return (Left b)
265 Right (a, r2) -> return (Right (a, liftStream r2))
266
267 -- | Clear variables from the environment for a subcomputation
268 withClearVars :: LlvmM a -> LlvmM a
269 withClearVars m = LlvmM $ \env -> do
270 (x, env') <- runLlvmM m env { envVarMap = emptyUFM, envStackRegs = [] }
271 return (x, env' { envVarMap = emptyUFM, envStackRegs = [] })
272
273 -- | Insert variables or functions into the environment.
274 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmM ()
275 varInsert s t = modifyEnv $ \env -> env { envVarMap = addToUFM (envVarMap env) s t }
276 funInsert s t = modifyEnv $ \env -> env { envFunMap = addToUFM (envFunMap env) s t }
277
278 -- | Lookup variables or functions in the environment.
279 varLookup, funLookup :: Uniquable key => key -> LlvmM (Maybe LlvmType)
280 varLookup s = getEnv (flip lookupUFM s . envVarMap)
281 funLookup s = getEnv (flip lookupUFM s . envFunMap)
282
283 -- | Set a register as allocated on the stack
284 markStackReg :: GlobalReg -> LlvmM ()
285 markStackReg r = modifyEnv $ \env -> env { envStackRegs = r : envStackRegs env }
286
287 -- | Check whether a register is allocated on the stack
288 checkStackReg :: GlobalReg -> LlvmM Bool
289 checkStackReg r = getEnv ((elem r) . envStackRegs)
290
291 -- | Allocate a new global unnamed metadata identifier
292 getMetaUniqueId :: LlvmM Int
293 getMetaUniqueId = LlvmM $ \env -> return (envFreshMeta env, env { envFreshMeta = envFreshMeta env + 1})
294
295 -- | Get the LLVM version we are generating code for
296 getLlvmVer :: LlvmM LlvmVersion
297 getLlvmVer = getEnv envVersion
298
299 -- | Get the platform we are generating code for
300 getDynFlag :: (DynFlags -> a) -> LlvmM a
301 getDynFlag f = getEnv (f . envDynFlags)
302
303 -- | Get the platform we are generating code for
304 getLlvmPlatform :: LlvmM Platform
305 getLlvmPlatform = getDynFlag targetPlatform
306
307 -- | Dumps the document if the corresponding flag has been set by the user
308 dumpIfSetLlvm :: DumpFlag -> String -> Outp.SDoc -> LlvmM ()
309 dumpIfSetLlvm flag hdr doc = do
310 dflags <- getDynFlags
311 liftIO $ dumpIfSet_dyn dflags flag hdr doc
312
313 -- | Prints the given contents to the output handle
314 renderLlvm :: Outp.SDoc -> LlvmM ()
315 renderLlvm sdoc = do
316
317 -- Write to output
318 dflags <- getDynFlags
319 out <- getEnv envOutput
320 let doc = Outp.withPprStyleDoc dflags (Outp.mkCodeStyle Outp.CStyle) sdoc
321 liftIO $ Prt.bufLeftRender out doc
322
323 -- Dump, if requested
324 dumpIfSetLlvm Opt_D_dump_llvm "LLVM Code" sdoc
325 return ()
326
327 -- | Run a @UniqSM@ action with our unique supply
328 runUs :: UniqSM a -> LlvmM a
329 runUs m = LlvmM $ \env -> do
330 let (x, us') = initUs (envUniq env) m
331 return (x, env { envUniq = us' })
332
333 -- | Marks a variable as "used"
334 markUsedVar :: LlvmVar -> LlvmM ()
335 markUsedVar v = modifyEnv $ \env -> env { envUsedVars = v : envUsedVars env }
336
337 -- | Return all variables marked as "used" so far
338 getUsedVars :: LlvmM [LlvmVar]
339 getUsedVars = getEnv envUsedVars
340
341 -- | Saves that at some point we didn't know the type of the label and
342 -- generated a reference to a type variable instead
343 saveAlias :: LMString -> LlvmM ()
344 saveAlias lbl = modifyEnv $ \env -> env { envAliases = addOneToUniqSet (envAliases env) lbl }
345
346 -- | Sets metadata node for a given unique
347 setUniqMeta :: Unique -> Int -> LlvmM ()
348 setUniqMeta f m = modifyEnv $ \env -> env { envUniqMeta = addToUFM (envUniqMeta env) f m }
349 -- | Gets metadata node for given unique
350 getUniqMeta :: Unique -> LlvmM (Maybe Int)
351 getUniqMeta s = getEnv (flip lookupUFM s . envUniqMeta)
352
353 -- ----------------------------------------------------------------------------
354 -- * Internal functions
355 --
356
357 -- | Here we pre-initialise some functions that are used internally by GHC
358 -- so as to make sure they have the most general type in the case that
359 -- user code also uses these functions but with a different type than GHC
360 -- internally. (Main offender is treating return type as 'void' instead of
361 -- 'void *'). Fixes trac #5486.
362 ghcInternalFunctions :: LlvmM ()
363 ghcInternalFunctions = do
364 dflags <- getDynFlags
365 mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
366 mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord dflags]
367 mk "memset" i8Ptr [i8Ptr, llvmWord dflags, llvmWord dflags]
368 mk "newSpark" (llvmWord dflags) [i8Ptr, i8Ptr]
369 where
370 mk n ret args = do
371 let n' = fsLit n `appendFS` fsLit "$def"
372 decl = LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
373 FixedArgs (tysToParams args) Nothing
374 renderLlvm $ ppLlvmFunctionDecl decl
375 funInsert n' (LMFunction decl)
376
377 -- ----------------------------------------------------------------------------
378 -- * Label handling
379 --
380
381 -- | Pretty print a 'CLabel'.
382 strCLabel_llvm :: CLabel -> LlvmM LMString
383 strCLabel_llvm lbl = do
384 platform <- getLlvmPlatform
385 dflags <- getDynFlags
386 let sdoc = pprCLabel platform lbl
387 str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
388 return (fsLit str)
389
390 strDisplayName_llvm :: CLabel -> LlvmM LMString
391 strDisplayName_llvm lbl = do
392 platform <- getLlvmPlatform
393 dflags <- getDynFlags
394 let sdoc = pprCLabel platform lbl
395 depth = Outp.PartWay 1
396 style = Outp.mkUserStyle Outp.reallyAlwaysQualify depth
397 str = Outp.renderWithStyle dflags sdoc style
398 return (fsLit (dropInfoSuffix str))
399
400 dropInfoSuffix :: String -> String
401 dropInfoSuffix = go
402 where go "_info" = []
403 go "_static_info" = []
404 go "_con_info" = []
405 go (x:xs) = x:go xs
406 go [] = []
407
408 strProcedureName_llvm :: CLabel -> LlvmM LMString
409 strProcedureName_llvm lbl = do
410 platform <- getLlvmPlatform
411 dflags <- getDynFlags
412 let sdoc = pprCLabel platform lbl
413 depth = Outp.PartWay 1
414 style = Outp.mkUserStyle Outp.neverQualify depth
415 str = Outp.renderWithStyle dflags sdoc style
416 return (fsLit str)
417
418 -- ----------------------------------------------------------------------------
419 -- * Global variables / forward references
420 --
421
422 -- | Create/get a pointer to a global value. Might return an alias if
423 -- the value in question hasn't been defined yet. We especially make
424 -- no guarantees on the type of the returned pointer.
425 getGlobalPtr :: LMString -> LlvmM LlvmVar
426 getGlobalPtr llvmLbl = do
427 m_ty <- funLookup llvmLbl
428 let mkGlbVar lbl ty = LMGlobalVar lbl (LMPointer ty) Private Nothing Nothing
429 case m_ty of
430 -- Directly reference if we have seen it already
431 Just ty -> return $ mkGlbVar (llvmLbl `appendFS` fsLit "$def") ty Global
432 -- Otherwise use a forward alias of it
433 Nothing -> do
434 saveAlias llvmLbl
435 return $ mkGlbVar llvmLbl i8 Alias
436
437 -- | Generate definitions for aliases forward-referenced by @getGlobalPtr@.
438 --
439 -- Must be called at a point where we are sure that no new global definitions
440 -- will be generated anymore!
441 generateExternDecls :: LlvmM ([LMGlobal], [LlvmType])
442 generateExternDecls = do
443 delayed <- fmap uniqSetToList $ getEnv envAliases
444 defss <- flip mapM delayed $ \lbl -> do
445 m_ty <- funLookup lbl
446 case m_ty of
447 -- If we have a definition we've already emitted the proper aliases
448 -- when the symbol itself was emitted by @aliasify@
449 Just _ -> return []
450
451 -- If we don't have a definition this is an external symbol and we
452 -- need to emit a declaration
453 Nothing ->
454 let var = LMGlobalVar lbl i8Ptr External Nothing Nothing Global
455 in return [LMGlobal var Nothing]
456
457 -- Reset forward list
458 modifyEnv $ \env -> env { envAliases = emptyUniqSet }
459 return (concat defss, [])
460
461 -- | Here we take a global variable definition, rename it with a
462 -- @$def@ suffix, and generate the appropriate alias.
463 aliasify :: LMGlobal -> LlvmM [LMGlobal]
464 aliasify (LMGlobal var val) = do
465 let i8Ptr = LMPointer (LMInt 8)
466 LMGlobalVar lbl ty link sect align const = var
467
468 defLbl = lbl `appendFS` fsLit "$def"
469 defVar = LMGlobalVar defLbl ty Internal sect align const
470
471 defPtrVar = LMGlobalVar defLbl (LMPointer ty) link Nothing Nothing const
472 aliasVar = LMGlobalVar lbl (LMPointer i8Ptr) link Nothing Nothing Alias
473 aliasVal = LMBitc (LMStaticPointer defPtrVar) i8Ptr
474
475 -- we need to mark the $def symbols as used so LLVM doesn't forget which
476 -- section they need to go in. This will vanish once we switch away from
477 -- mangling sections for TNTC.
478 markUsedVar defVar
479
480 return [ LMGlobal defVar val
481 , LMGlobal aliasVar (Just aliasVal)
482 ]
483
484 -- Note [Llvm Forward References]
485 --
486 -- The issue here is that LLVM insists on being strongly typed at
487 -- every corner, so the first time we mention something, we have to
488 -- settle what type we assign to it. That makes things awkward, as Cmm
489 -- will often reference things before their definition, and we have no
490 -- idea what (LLVM) type it is going to be before that point.
491 --
492 -- Our work-around is to define "aliases" of a standard type (i8 *) in
493 -- these kind of situations, which we later tell LLVM to be either
494 -- references to their actual local definitions (involving a cast) or
495 -- an external reference. This obviously only works for pointers.
496 --
497 -- In particular when we encounter a reference to a symbol in a chunk of
498 -- C-- there are three possible scenarios,
499 --
500 -- 1. We have already seen a definition for the referenced symbol. This
501 -- means we already know its type.
502 --
503 -- 2. We have not yet seen a definition but we will find one later in this
504 -- compilation unit. Since we want to be a good consumer of the
505 -- C-- streamed to us from upstream, we don't know the type of the
506 -- symbol at the time when we must emit the reference.
507 --
508 -- 3. We have not yet seen a definition nor will we find one in this
509 -- compilation unit. In this case the reference refers to an
510 -- external symbol for which we do not know the type.
511 --
512 -- Let's consider case (2) for a moment: say we see a reference to
513 -- the symbol @fooBar@ for which we have not seen a definition. As we
514 -- do not know the symbol's type, we assume it is of type @i8*@ and emit
515 -- the appropriate casts in @getSymbolPtr@. Later on, when we
516 -- encounter the definition of @fooBar@ we emit it but with a modified
517 -- name, @fooBar$def@ (which we'll call the definition symbol), to
518 -- since we have already had to assume that the symbol @fooBar@
519 -- is of type @i8*@. We then emit @fooBar@ itself as an alias
520 -- of @fooBar$def@ with appropriate casts. This all happens in
521 -- @aliasify@.
522 --
523 -- Case (3) is quite similar to (2): References are emitted assuming
524 -- the referenced symbol is of type @i8*@. When we arrive at the end of
525 -- the compilation unit and realize that the symbol is external, we emit
526 -- an LLVM @external global@ declaration for the symbol @fooBar@
527 -- (handled in @generateExternDecls@). This takes advantage of the
528 -- fact that the aliases produced by @aliasify@ for exported symbols
529 -- have external linkage and can therefore be used as normal symbols.
530 --
531 -- Historical note: As of release 3.5 LLVM does not allow aliases to
532 -- refer to declarations. This the reason why aliases are produced at the
533 -- point of definition instead of the point of usage, as was previously
534 -- done. See #9142 for details.
535 --
536 -- Finally, case (1) is trival. As we already have a definition for
537 -- and therefore know the type of the referenced symbol, we can do
538 -- away with casting the alias to the desired type in @getSymbolPtr@
539 -- and instead just emit a reference to the definition symbol directly.
540 -- This is the @Just@ case in @getSymbolPtr@.