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