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