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