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