More CPP removal: pprDynamicLinkerAsmLabel in CLabel
[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)) = LlvmEnv (e1, emptyUFM, n, p)
162
163 -- | Insert functions into the environment.
164 varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv
165 varInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (e1, addToUFM e2 s t, n, p)
166 funInsert s t (LlvmEnv (e1, e2, n, p)) = LlvmEnv (addToUFM e1 s t, e2, n, p)
167
168 -- | Lookup functions in the environment.
169 varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType
170 varLookup s (LlvmEnv (_, e2, _, _)) = lookupUFM e2 s
171 funLookup s (LlvmEnv (e1, _, _, _)) = lookupUFM e1 s
172
173 -- | Get the LLVM version we are generating code for
174 getLlvmVer :: LlvmEnv -> LlvmVersion
175 getLlvmVer (LlvmEnv (_, _, n, _)) = n
176
177 -- | Set the LLVM version we are generating code for
178 setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv
179 setLlvmVer n (LlvmEnv (e1, e2, _, p)) = LlvmEnv (e1, e2, n, p)
180
181 -- | Get the platform we are generating code for
182 getLlvmPlatform :: LlvmEnv -> Platform
183 getLlvmPlatform (LlvmEnv (_, _, _, p)) = p
184
185 -- ----------------------------------------------------------------------------
186 -- * Label handling
187 --
188
189 -- | Pretty print a 'CLabel'.
190 strCLabel_llvm :: LlvmEnv -> CLabel -> LMString
191 strCLabel_llvm env l
192 = (fsLit . show . llvmSDoc . pprCLabel (getLlvmPlatform env)) l
193
194 -- | Create an external definition for a 'CLabel' defined in another module.
195 genCmmLabelRef :: LlvmEnv -> CLabel -> LMGlobal
196 genCmmLabelRef env = genStringLabelRef . strCLabel_llvm env
197
198 -- | As above ('genCmmLabelRef') but taking a 'LMString', not 'CLabel'.
199 genStringLabelRef :: LMString -> LMGlobal
200 genStringLabelRef cl
201 = let ty = LMPointer $ LMArray 0 llvmWord
202 in (LMGlobalVar cl ty External Nothing Nothing False, Nothing)
203
204
205 -- ----------------------------------------------------------------------------
206 -- * Misc
207 --
208
209 -- | Error function
210 panic :: String -> a
211 panic s = Outp.panic $ "LlvmCodeGen.Base." ++ s
212