Fix inverted test for platformUnregisterised (should fix the optllvm breakage)
[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 toParams x | isPointer x = (x, [NoAlias, NoCapture])
103 | otherwise = (x, [])
104 in LlvmFunctionDecl lbl link (llvmGhcCC dflags) LMVoid FixedArgs
105 (map (toParams . getVarType) llvmFunArgs) llvmFunAlign
106
107 -- | Create a Haskell function in LLVM.
108 mkLlvmFunc :: LlvmEnv -> CLabel -> LlvmLinkageType -> LMSection -> LlvmBlocks
109 -> LlvmFunction
110 mkLlvmFunc env lbl link sec blks
111 = let funDec = llvmFunSig env lbl link
112 funArgs = map (fsLit . getPlainName) llvmFunArgs
113 in LlvmFunction funDec funArgs llvmStdFunAttrs sec blks
114
115 -- | Alignment to use for functions
116 llvmFunAlign :: LMAlign
117 llvmFunAlign = Just wORD_SIZE
118
119 -- | Alignment to use for into tables
120 llvmInfAlign :: LMAlign
121 llvmInfAlign = Just wORD_SIZE
122
123 -- | A Function's arguments
124 llvmFunArgs :: [LlvmVar]
125 llvmFunArgs = map lmGlobalRegArg activeStgRegs
126
127 -- | Llvm standard fun attributes
128 llvmStdFunAttrs :: [LlvmFuncAttr]
129 llvmStdFunAttrs = [NoUnwind]
130
131 -- | Convert a list of types to a list of function parameters
132 -- (each with no parameter attributes)
133 tysToParams :: [LlvmType] -> [LlvmParameter]
134 tysToParams = map (\ty -> (ty, []))
135
136 -- | Pointer width
137 llvmPtrBits :: Int
138 llvmPtrBits = widthInBits $ typeWidth gcWord
139
140 -- ----------------------------------------------------------------------------
141 -- * Llvm Version
142 --
143
144 -- | LLVM Version Number
145 type LlvmVersion = Int
146
147 -- | The LLVM Version we assume if we don't know
148 defaultLlvmVersion :: LlvmVersion
149 defaultLlvmVersion = 30
150
151 minSupportLlvmVersion :: LlvmVersion
152 minSupportLlvmVersion = 28
153
154 maxSupportLlvmVersion :: LlvmVersion
155 maxSupportLlvmVersion = 31
156
157 -- ----------------------------------------------------------------------------
158 -- * Environment Handling
159 --
160
161 -- two maps, one for functions and one for local vars.
162 newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion, DynFlags)
163
164 type LlvmEnvMap = UniqFM LlvmType
165
166 -- | Get initial Llvm environment.
167 initLlvmEnv :: DynFlags -> LlvmEnv
168 initLlvmEnv dflags = LlvmEnv (initFuncs, emptyUFM, defaultLlvmVersion, dflags)
169 where initFuncs = listToUFM $ [ (n, LMFunction ty) | (n, ty) <- ghcInternalFunctions ]
170
171 -- | Here we pre-initialise some functions that are used internally by GHC
172 -- so as to make sure they have the most general type in the case that
173 -- user code also uses these functions but with a different type than GHC
174 -- internally. (Main offender is treating return type as 'void' instead of
175 -- 'void *'. Fixes trac #5486.
176 ghcInternalFunctions :: [(LMString, LlvmFunctionDecl)]
177 ghcInternalFunctions =
178 [ mk "memcpy" i8Ptr [i8Ptr, i8Ptr, llvmWord]
179 , mk "memmove" i8Ptr [i8Ptr, i8Ptr, llvmWord]
180 , mk "memset" i8Ptr [i8Ptr, llvmWord, llvmWord]
181 , mk "newSpark" llvmWord [i8Ptr, i8Ptr]
182 ]
183 where
184 mk n ret args =
185 let n' = fsLit n
186 in (n', LlvmFunctionDecl n' ExternallyVisible CC_Ccc ret
187 FixedArgs (tysToParams args) Nothing)
188
189 -- | Clear variables from the environment.
190 clearVars :: LlvmEnv -> LlvmEnv
191 clearVars (LlvmEnv (e1, _, n, p)) = {-# SCC "llvm_env_clear" #-}
192 LlvmEnv (e1, emptyUFM, n, p)
193
194 -- | Insert local variables into the environment.
195 varInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
196 varInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_vinsert" #-}
197 LlvmEnv (e1, addToUFM e2 s t, n, p)
198
199 -- | Insert functions into the environment.
200 funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
201 funInsert s t (LlvmEnv (e1, e2, n, p)) = {-# SCC "llvm_env_finsert" #-}
202 LlvmEnv (addToUFM e1 s t, e2, n, p)
203
204 -- | Lookup local variables in the environment.
205 varLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
206 varLookup s (LlvmEnv (_, e2, _, _)) = {-# SCC "llvm_env_vlookup" #-}
207 lookupUFM e2 s
208
209 -- | Lookup functions in the environment.
210 funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
211 funLookup s (LlvmEnv (e1, _, _, _)) = {-# SCC "llvm_env_flookup" #-}
212 lookupUFM e1 s
213
214 -- | Get the LLVM version we are generating code for
215 getLlvmVer :: LlvmEnv -> LlvmVersion
216 getLlvmVer (LlvmEnv (_, _, n, _)) = n
217
218 -- | Set the LLVM version we are generating code for
219 setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
220 setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
221
222 -- | Get the platform we are generating code for
223 getLlvmPlatform :: LlvmEnv -> Platform
224 getLlvmPlatform (LlvmEnv (_, _, _, d)) = targetPlatform d
225
226 -- | Get the DynFlags for this compilation pass
227 getDflags :: LlvmEnv -> DynFlags
228 getDflags (LlvmEnv (_, _, _, d)) = d
229
230 -- ----------------------------------------------------------------------------
231 -- * Label handling
232 --
233
234 -- | Pretty print a 'CLabel'.
235 strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
236 strCLabel_llvm env l = {-# SCC "llvm_strCLabel" #-}
237 (fsLit . toString . pprCLabel (getLlvmPlatform env)) l
238 where dflags = getDflags env
239 style = Outp.mkCodeStyle Outp.CStyle
240 toString doc = Outp.renderWithStyle dflags doc style
241
242 -- | Create an external definition for a 'CLabel' defined in another module.
243 genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
244 genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env
245
246 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
247 genStringLabelRef :: LMString -> LMGlobal
248 genStringLabelRef cl
249 = let ty = LMPointer $ LMArray 0 llvmWord
250 in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
251
252 -- ----------------------------------------------------------------------------
253 -- * Misc
254 --
255
256 -- | Error function
257 panic :: String -> a
258 panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s
259