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