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