Merge branch 'master' of http://darcs.haskell.org/ghc
[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 dflags 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 dflags = getDflags env
131 (env', var, glob) = resData env (Left (CmmLabel label))
132 offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
133 in (env', LMAdd var offset, glob)
134
135 resData env (Left (CmmLabelDiffOff l1 l2 off)) =
136 let dflags = getDflags env
137 (env1, var1, glob1) = resData env (Left (CmmLabel l1))
138 (env2, var2, glob2) = resData env1 (Left (CmmLabel l2))
139 var = LMSub var1 var2
140 offset = LMStaticLit $ LMIntLit (toInteger off) (llvmWord dflags)
141 in (env2, LMAdd var offset, glob1 ++ glob2)
142
143 resData _ _ = panic "resData: Non CLabel expr as left type!"
144
145 -- ----------------------------------------------------------------------------
146 -- * Generate static data
147 --
148
149 -- | Handle static data
150 genData :: CmmStatic -> UnresStatic
151
152 genData (CmmString str) =
153 let v = map (\x -> LMStaticLit $ LMIntLit (fromIntegral x) i8) str
154 ve = v ++ [LMStaticLit $ LMIntLit 0 i8]
155 in Right $ LMStaticArray ve (LMArray (length ve) i8)
156
157 genData (CmmUninitialised bytes)
158 = Right $ LMUninitType (LMArray bytes i8)
159
160 genData (CmmStaticLit lit)
161 = genStaticLit lit
162
163 -- | Generate Llvm code for a static literal.
164 --
165 -- Will either generate the code or leave it unresolved if it is a 'CLabel'
166 -- which isn't yet known.
167 genStaticLit :: CmmLit -> UnresStatic
168 genStaticLit (CmmInt i w)
169 = Right $ LMStaticLit (LMIntLit i (LMInt $ widthInBits w))
170
171 genStaticLit (CmmFloat r w)
172 = Right $ LMStaticLit (LMFloatLit (fromRational r) (widthToLlvmFloat w))
173
174 -- Leave unresolved, will fix later
175 genStaticLit c@(CmmLabel _ ) = Left $ c
176 genStaticLit c@(CmmLabelOff _ _) = Left $ c
177 genStaticLit c@(CmmLabelDiffOff _ _ _) = Left $ c
178
179 genStaticLit (CmmBlock b) = Left $ CmmLabel $ infoTblLbl b
180
181 genStaticLit (CmmHighStackMark)
182 = panic "genStaticLit: CmmHighStackMark unsupported!"
183
184 -- -----------------------------------------------------------------------------
185 -- * Misc
186 --
187
188 -- | Error Function
189 panic :: String -> a
190 panic s = Outputable.panic $ "LlvmCodeGen.Data." ++ s
191