Fix negate op not working for -0 in llvm backend
[ghc.git] / compiler / llvmGen / LlvmCodeGen / Data.hs
1 -- ----------------------------------------------------------------------------
2 -- | Handle conversion of CmmData to LLVM code.
3 --
4
5 module LlvmCodeGen.Data (
6 genLlvmData, resolveLlvmDatas, resolveLlvmData
7 ) where
8
9 #include "HsVersions.h"
10
11 import Llvm
12 import LlvmCodeGen.Base
13
14 import BlockId
15 import CLabel
16 import Cmm
17
18 import DynFlags
19 import FastString
20 import qualified Outputable
21
22 import Data.Maybe
23
24
25 -- ----------------------------------------------------------------------------
26 -- * Constants
27 --
28
29 -- | The string appended to a variable name to create its structure type alias
30 structStr :: LMString
31 structStr = fsLit "_struct"
32
33 -- ----------------------------------------------------------------------------
34 -- * Top level
35 --
36
37 -- | Pass a CmmStatic section to an equivalent Llvm code. Can't
38 -- complete this completely though as we need to pass all CmmStatic
39 -- sections before all references can be resolved. This last step is
40 -- done by 'resolveLlvmData'.
41 genLlvmData :: DynFlags -> (Section, [CmmStatic]) -> LlvmUnresData
42 genLlvmData _ ( _ , (CmmDataLabel lbl):xs) =
43 let static = map genData xs
44 label = strCLabel_llvm lbl
45
46 types = map getStatTypes static
47 getStatTypes (Left x) = cmmToLlvmType $ cmmLitType x
48 getStatTypes (Right x) = getStatType x
49
50 strucTy = LMStruct types
51 alias = LMAlias (label `appendFS` structStr) strucTy
52 in (lbl, alias, static)
53
54 genLlvmData _ _ = panic "genLlvmData: CmmData section doesn't start with label!"
55
56 resolveLlvmDatas :: DynFlags -> LlvmEnv -> [LlvmUnresData] -> [LlvmData]
57 -> (LlvmEnv, [LlvmData])
58 resolveLlvmDatas _ env [] ldata
59 = (env, ldata)
60
61 resolveLlvmDatas dflags env (udata : rest) ldata
62 = let (env', ndata) = resolveLlvmData dflags env udata
63 in resolveLlvmDatas dflags env' rest (ldata ++ [ndata])
64
65 -- | Fix up CLabel references now that we should have passed all CmmData.
66 resolveLlvmData :: DynFlags -> LlvmEnv -> LlvmUnresData -> (LlvmEnv, LlvmData)
67 resolveLlvmData _ env (lbl, alias, unres) =
68 let (env', static, refs) = resDatas env unres ([], [])
69 refs' = catMaybes refs
70 struct = Just $ LMStaticStruc static alias
71 label = strCLabel_llvm lbl
72 link = if (externallyVisibleCLabel lbl)
73 then ExternallyVisible else Internal
74 glob = LMGlobalVar label alias link Nothing Nothing
75 in (env', (refs' ++ [(glob, struct)], [alias]))
76
77
78 -- ----------------------------------------------------------------------------
79 -- ** Resolve Data/CLabel references
80 --
81
82 -- | Resolve data list
83 resDatas :: LlvmEnv -> [UnresStatic] -> ([LlvmStatic], [Maybe LMGlobal])
84 -> (LlvmEnv, [LlvmStatic], [Maybe LMGlobal])
85
86 resDatas env [] (stat, glob)
87 = (env, stat, glob)
88
89 resDatas env (cmm : rest) (stats, globs)
90 = let (env', nstat, nglob) = resData env cmm
91 in resDatas env' rest (stats ++ [nstat], globs ++ nglob)
92
93 -- | Resolve an individual static label if it needs to be.
94 --
95 -- We check the 'LlvmEnv' to see if the reference has been defined in this
96 -- module. If it has we can retrieve its type and make a pointer, otherwise
97 -- we introduce a generic external defenition for the referenced label and
98 -- then make a pointer.
99 resData :: LlvmEnv -> UnresStatic -> (LlvmEnv, LlvmStatic, [Maybe LMGlobal])
100
101 resData env (Right stat) = (env, stat, [Nothing])
102
103 resData env (Left cmm@(CmmLabel l)) =
104 let label = strCLabel_llvm l
105 ty = funLookup label env
106 lmty = cmmToLlvmType $ cmmLitType cmm
107 in case ty of
108 -- Make generic external label defenition and then pointer to it
109 Nothing ->
110 let glob@(var, _) = genStringLabelRef label
111 env' = funInsert label (pLower $ getVarType var) env
112 ptr = LMStaticPointer var
113 in (env', LMPtoI ptr lmty, [Just glob])
114 -- Referenced data exists in this module, retrieve type and make
115 -- pointer to it.
116 Just ty' ->
117 let var = LMGlobalVar label (LMPointer ty')
118 ExternallyVisible Nothing Nothing
119 ptr = LMStaticPointer var
120 in (env, LMPtoI ptr lmty, [Nothing])
121
122 resData env (Left (CmmLabelOff label off)) =
123 let (env', var, glob) = resData env (Left (CmmLabel label))
124 offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord
125 in (env', LMAdd var offset, glob)
126
127 resData env (Left (CmmLabelDiffOff l1 l2 off)) =
128 let (env1, var1, glob1) = resData env (Left (CmmLabel l1))
129 (env2, var2, glob2) = resData env1 (Left (CmmLabel l2))
130 var = LMSub var1 var2
131 offset = LMStaticLit $ LMIntLit (toInteger off) llvmWord
132 in (env2, LMAdd var offset, glob1 ++ glob2)
133
134 resData _ _ = panic "resData: Non CLabel expr as left type!"
135
136 -- ----------------------------------------------------------------------------
137 -- * Generate static data
138 --
139
140 -- | Handle static data
141 -- Don't handle 'CmmAlign' or a 'CmmDataLabel'.
142 genData :: CmmStatic -> UnresStatic
143
144 genData (CmmString str) =
145 let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
146 ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
147 in Right $ LMStaticArray ve (LMArray (length ve) i8)
148
149 genData (CmmUninitialised bytes)
150 = Right $ LMUninitType (LMArray bytes i8)
151
152 genData (CmmStaticLit lit)
153 = genStaticLit lit
154
155 genData (CmmAlign _)
156 = panic "genData: Can't handle CmmAlign!"
157
158 genData (CmmDataLabel _)
159 = panic "genData: Can't handle data labels not at top of data!"
160
161
162 -- | Generate Llvm code for a static literal.
163 --
164 -- Will either generate the code or leave it unresolved if it is a 'CLabel'
165 -- which isn't yet known.
166 genStaticLit :: CmmLit -> UnresStatic
167 genStaticLit (CmmInt i w)
168 = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
169
170 genStaticLit (CmmFloat r w)
171 = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
172
173 -- Leave unresolved, will fix later
174 genStaticLit c@(CmmLabel _ ) = Left $ c
175 genStaticLit c@(CmmLabelOff _ _) = Left $ c
176 genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c
177
178 genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
179
180 genStaticLit (CmmHighStackMark)
181 = panic "genStaticLit: CmmHighStackMark unsupported!"
182
183
184 -- -----------------------------------------------------------------------------
185 -- * Misc
186 --
187
188 -- | Error Function
189 panic :: String -> a
190 panic s = Outputable.panic $ "LlvmCodeGen.Data." ++ s
191