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