Pass DynFlags down to gcWord
[ghc.git] / compiler / llvmGen / LlvmCodeGen / Base.hs
1 -- ----------------------------------------------------------------------------
2 -- | Base LLVM Code Generation module
3 --
4 -- Contains functions useful through out the code generator.
5 --
6
7 module LlvmCodeGen.Base (
8
9 LlvmCmmDecl, LlvmBasicBlock,
10 LlvmUnresData, LlvmData, UnresLabel, UnresStatic,
11
12 LlvmVersion, defaultLlvmVersion, minSupportLlvmVersion,
13 maxSupportLlvmVersion,
14
15 LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert,
16 funLookup, funInsert, getLlvmVer, setLlvmVer, getLlvmPlatform,
17 getDflags, ghcInternalFunctions,
18
19 cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy,
20 llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign,
21 llvmPtrBits, mkLlvmFunc, tysToParams,
22
23 strCLabel_llvm, genCmmLabelRef, genStringLabelRef
24
25 ) where
26
27 #include "HsVersions.h"
28
29 import Llvm
30 import LlvmCodeGen.Regs
31
32 import CLabel
33 import CgUtils ( activeStgRegs )
34 import Constants
35 import DynFlags
36 import FastString
37 import OldCmm
38 import qualified Outputable as Outp
39 import Platform
40 import UniqFM
41 import Unique
42
43 -- ----------------------------------------------------------------------------
44 -- * Some Data Types
45 --
46
47 type LlvmCmmDecl = GenCmmDecl [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement)
48 type LlvmBasicBlock = GenBasicBlock LlvmStatement
49
50 -- | Unresolved code.
51 -- Of the form: (data label, data type, unresolved data)
52 type LlvmUnresData = (CLabel, Section, LlvmType, [UnresStatic])
53
54 -- | Top level LLVM Data (globals and type aliases)
55 type LlvmData = ([LMGlobal], [LlvmType])
56
57 -- | An unresolved Label.
58 --
59 -- Labels are unresolved when we haven't yet determined if they are defined in
60 -- the module we are currently compiling, or an external one.
61 type UnresLabel = CmmLit
62 type UnresStatic = Either UnresLabel LlvmStatic
63
64 -- ----------------------------------------------------------------------------
65 -- * Type translations
66 --
67
68 -- | Translate a basic CmmType to an LlvmType.
69 cmmToLlvmType :: CmmType -> LlvmType
70 cmmToLlvmType ty | isFloatType ty = widthToLlvmFloat $ typeWidth ty
71 | otherwise = widthToLlvmInt $ typeWidth ty
72
73 -- | Translate a Cmm Float Width to a LlvmType.
74 widthToLlvmFloat :: Width -> LlvmType
75 widthToLlvmFloat W32 = LMFloat
76 widthToLlvmFloat W64 = LMDouble
77 widthToLlvmFloat W80 = LMFloat80
78 widthToLlvmFloat W128 = LMFloat128
79 widthToLlvmFloat w = panic $ "widthToLlvmFloat: Bad float size: " ++ show w
80
81 -- | Translate a Cmm Bit Width to a LlvmType.
82 widthToLlvmInt :: Width -> LlvmType
83 widthToLlvmInt w = LMInt $ widthInBits w
84
85 -- | GHC Call Convention for LLVM
86 llvmGhcCC :: DynFlags -> LlvmCallConvention
87 llvmGhcCC dflags
88 | platformUnregisterised (targetPlatform dflags) = CC_Ccc
89 | otherwise = CC_Ncc 10
90
91 -- | Llvm Function type for Cmm function
92 llvmFunTy :: DynFlags -> LlvmType
93 llvmFunTy dflags = LMFunction $ llvmFunSig' dflags (fsLit "a") ExternallyVisible
94
95 -- | Llvm Function signature
96 llvmFunSig :: LlvmEnv -> CLabel -> LlvmLinkageType -> LlvmFunctionDecl
97 llvmFunSig env lbl link
98 = llvmFunSig' (getDflags env) (strCLabel_llvm env lbl) link
99
100 llvmFunSig' :: DynFlags -> LMString -> LlvmLinkageType -> LlvmFunctionDecl
101 llvmFunSig' dflags lbl link
102 = let platform = targetPlatform dflags
103 toParams x | isPointer x = (x, [NoAlias, NoCapture])
104 | otherwise = (x, [])
105 in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
106 (map (toParams . getVarType) (llvmFunArgs platform))
107 llvmFunAlign
108
109 -- | Create a Haskell function in LLVM.
110 mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
111 -> LlvmFunction
112 mkLlvmFunc env lbl link sec blks
113 = let platform = targetPlatform $ getDflags env
114 funDec = llvmFunSig env lbl link
115 funArgs = map (fsLit . getPlainName) (llvmFunArgs platform)
116 in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
117
118 -- | Alignment to use for functions
119 llvmFunAlign :: LMAlign
120 llvmFunAlign = Just wORD_SIZE
121
122 -- | Alignment to use for into tables
123 llvmInfAlign :: LMAlign
124 llvmInfAlign = Just wORD_SIZE
125
126 -- | A Function's arguments
127 llvmFunArgs :: Platform -> [LlvmVar]
128 llvmFunArgs platform = map lmGlobalRegArg (activeStgRegs platform)
129
130 -- | Llvm standard fun attributes
131 llvmStdFunAttrs :: [LlvmFuncAttr]
132 llvmStdFunAttrs = [NoUnwind]
133
134 -- | Convert a list of types to a list of function parameters
135 -- (each with no parameter attributes)
136 tysToParams :: [LlvmType] -> [LlvmParameter]
137 tysToParams = map (\ty -> (ty, []))
138
139 -- | Pointer width
140 llvmPtrBits :: DynFlags -> Int
141 llvmPtrBits dflags = widthInBits $ typeWidth $ gcWord dflags
142
143 -- ----------------------------------------------------------------------------
144 -- * Llvm Version
145 --
146
147 -- | LLVM Version Number
148 type LlvmVersion = Int
149
150 -- | The LLVM Version we assume if we don't know
151 defaultLlvmVersion :: LlvmVersion
152 defaultLlvmVersion = 30
153
154 minSupportLlvmVersion :: LlvmVersion
155 minSupportLlvmVersion = 28
156
157 maxSupportLlvmVersion :: LlvmVersion
158 maxSupportLlvmVersion = 31
159
160 -- ----------------------------------------------------------------------------
161 -- * Environment Handling
162 --
163
164 -- two maps, one for functions and one for local vars.
165 newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
166
167 type LlvmEnvMap = UniqFM LlvmType
168
169 -- | Get initial Llvm environment.
170 initLlvmEnv :: DynFlags -> LlvmEnv
171 initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
172 where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ]
173
174 -- | Here we pre-initialise some functions that are used internally by GHC
175 -- so as to make sure they have the most general type in the case that
176 -- user code also uses these functions but with a different type than GHC
177 -- internally. (Main offender is treating return type as 'void' instead of
178 -- 'void *'. Fixes trac #5486.
179 ghcInternalFunctions :: [(LMString, LlvmFunctionDecl)]
180 ghcInternalFunctions =
181 [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord]
182 , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord]
183 , mk "memset" i8Ptr [i8Ptr, llvmWord, llvmWord]
184 , mk "newSpark" llvmWord [i8Ptr, i8Ptr]
185 ]
186 where
187 mk n ret args =
188 let n' = fsLit n
189 in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
190 FixedArgs (tysToParams args) Nothing)
191
192 -- | Clear variables from the environment.
193 clearVars :: LlvmEnv -> LlvmEnv
194 clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
195 LlvmEnv (e1, emptyUFM, n, p)
196
197 -- | Insert local variables into the environment.
198 varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
199 varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
200 LlvmEnv (e1, addToUFM e2 s t, n, p)
201
202 -- | Insert functions into the environment.
203 funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
204 funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
205 LlvmEnv (addToUFM e1 s t, e2, n, p)
206
207 -- | Lookup local variables in the environment.
208 varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
209 varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
210 lookupUFM e2 s
211
212 -- | Lookup functions in the environment.
213 funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
214 funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
215 lookupUFM e1 s
216
217 -- | Get the LLVM version we are generating code for
218 getLlvmVer :: LlvmEnv -> LlvmVersion
219 getLlvmVer (LlvmEnv (_, _, n, _)) = n
220
221 -- | Set the LLVM version we are generating code for
222 setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
223 setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
224
225 -- | Get the platform we are generating code for
226 getLlvmPlatform :: LlvmEnv -> Platform
227 getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
228
229 -- | Get the DynFlags for this compilation pass
230 getDflags :: LlvmEnv -> DynFlags
231 getDflags (LlvmEnv (_, _, _, d)) = d
232
233 -- ----------------------------------------------------------------------------
234 -- * Label handling
235 --
236
237 -- | Pretty print a 'CLabel'.
238 strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
239 strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
240 (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
241 where dflags = getDflags env
242 style = Outp.mkCodeStyle Outp.CStyle
243 toString doc = Outp.renderWithStyle dflags doc style
244
245 -- | Create an external definition for a 'CLabel' defined in another module.
246 genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
247 genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env
248
249 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
250 genStringLabelRef :: LMString -> LMGlobal
251 genStringLabelRef cl
252 = let ty = LMPointer $ LMArray 0 llvmWord
253 in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
254
255 -- ----------------------------------------------------------------------------
256 -- * Misc
257 --
258
259 -- | Error function
260 panic :: String -> a
261 panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s
262