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