Fix warnings in CmmInfo
[ghc.git] / compiler / cmm / CmmInfo.hs
1 module CmmInfo (
2 emptyContInfoTable,
3 cmmToRawCmm,
4 mkInfoTable,
5 mkBareInfoTable
6 ) where
7
8 #include "HsVersions.h"
9
10 import Cmm
11 import CmmUtils
12
13 import CLabel
14
15 import Bitmap
16 import ClosureInfo
17 import CgInfoTbls
18 import CgCallConv
19 import CgUtils
20 import SMRep
21 import ZipCfgCmmRep
22
23 import Constants
24 import StaticFlags
25 import Unique
26 import UniqSupply
27 import Panic
28
29 import Data.Bits
30
31 -- When we split at proc points, we need an empty info table.
32 emptyContInfoTable :: CmmInfo
33 emptyContInfoTable =
34 CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
35 (ContInfo [] NoC_SRT))
36 where zero = CmmInt 0 wordWidth
37
38 cmmToRawCmm :: [Cmm] -> IO [RawCmm]
39 cmmToRawCmm cmm = do
40 info_tbl_uniques <- mkSplitUniqSupply 'i'
41 return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
42 where
43 raw_cmm uniq_supply (Cmm procs) =
44 Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs
45
46 -- Make a concrete info table, represented as a list of CmmStatic
47 -- (it can't be simply a list of Word, because the SRT field is
48 -- represented by a label+offset expression).
49 --
50 -- With tablesNextToCode, the layout is
51 -- <reversed variable part>
52 -- <normal forward StgInfoTable, but without
53 -- an entry point at the front>
54 -- <code>
55 --
56 -- Without tablesNextToCode, the layout of an info table is
57 -- <entry label>
58 -- <normal forward rest of StgInfoTable>
59 -- <forward variable part>
60 --
61 -- See includes/InfoTables.h
62 --
63 -- For return-points these are as follows
64 --
65 -- Tables next to code:
66 --
67 -- <srt slot>
68 -- <standard info table>
69 -- ret-addr --> <entry code (if any)>
70 --
71 -- Not tables-next-to-code:
72 --
73 -- ret-addr --> <ptr to entry code>
74 -- <standard info table>
75 -- <srt slot>
76 --
77 -- * The SRT slot is only there if there is SRT info to record
78
79 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
80 mkInfoTable _ (CmmData sec dat) = [CmmData sec dat]
81 mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
82 case info of
83 -- Code without an info table. Easy.
84 CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
85
86 CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
87 let info_label = entryLblToInfoLbl entry_label
88 ty_prof' = makeRelativeRefTo info_label ty_prof
89 cl_prof' = makeRelativeRefTo info_label cl_prof
90 in case type_info of
91 -- A function entry point.
92 FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry ->
93 mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
94 arguments blocks
95 where
96 fun_type = argDescrType pap_bitmap
97 fun_extra_bits =
98 [packHalfWordsCLit fun_type fun_arity] ++
99 case pap_bitmap of
100 ArgGen liveness ->
101 (if null srt_label then [mkIntCLit 0] else srt_label) ++
102 [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
103 makeRelativeRefTo info_label slow_entry]
104 _ -> srt_label
105 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap
106 layout
107 (srt_label, srt_bitmap) = mkSRTLit info_label srt
108 layout = packHalfWordsCLit ptrs nptrs
109
110 -- A constructor.
111 ConstrInfo (ptrs, nptrs) con_tag descr ->
112 mkInfoTableAndCode info_label std_info [con_name] entry_label
113 arguments blocks
114 where
115 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
116 con_name = makeRelativeRefTo info_label descr
117 layout = packHalfWordsCLit ptrs nptrs
118 -- A thunk.
119 ThunkInfo (ptrs, nptrs) srt ->
120 mkInfoTableAndCode info_label std_info srt_label entry_label
121 arguments blocks
122 where
123 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout
124 (srt_label, srt_bitmap) = mkSRTLit info_label srt
125 layout = packHalfWordsCLit ptrs nptrs
126
127 -- A selector thunk.
128 ThunkSelectorInfo offset _srt ->
129 mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
130 arguments blocks
131 where
132 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
133
134 -- A continuation/return-point.
135 ContInfo stack_layout srt ->
136 liveness_data ++
137 mkInfoTableAndCode info_label std_info srt_label entry_label
138 arguments blocks
139 where
140 std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap
141 (makeRelativeRefTo info_label liveness_lit)
142 (liveness_lit, liveness_data, liveness_tag) =
143 mkLiveness uniq stack_layout
144 maybe_big_type_tag = if type_tag == rET_SMALL
145 then liveness_tag
146 else type_tag
147 (srt_label, srt_bitmap) = mkSRTLit info_label srt
148
149 -- Generate a bare info table, not attached to any procedure.
150 mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
151 mkBareInfoTable lbl uniq info =
152 case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
153 [CmmProc d _ _ _] ->
154 ASSERT (tablesNextToCode)
155 [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
156 [CmmData d s] -> [CmmData d s]
157 _ -> panic "mkBareInfoTable expected to produce only data"
158
159
160 -- Handle the differences between tables-next-to-code
161 -- and not tables-next-to-code
162 mkInfoTableAndCode :: CLabel
163 -> [CmmLit]
164 -> [CmmLit]
165 -> CLabel
166 -> CmmFormals
167 -> ListGraph CmmStmt
168 -> [RawCmmTop]
169 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
170 | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
171 = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
172 entry_lbl args blocks]
173
174 | ListGraph [] <- blocks -- No code; only the info table is significant
175 = -- Use a zero place-holder in place of the
176 -- entry-label in the info table
177 [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
178
179 | otherwise -- Separately emit info table (with the function entry
180 = -- point as first entry) and the entry code
181 [CmmProc [] entry_lbl args blocks,
182 mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
183
184 mkSRTLit :: CLabel
185 -> C_SRT
186 -> ([CmmLit], -- srt_label
187 StgHalfWord) -- srt_bitmap
188 mkSRTLit _ NoC_SRT = ([], 0)
189 mkSRTLit info_label (C_SRT lbl off bitmap) =
190 ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
191
192 -------------------------------------------------------------------------
193 --
194 -- Build a liveness mask for the stack layout
195 --
196 -------------------------------------------------------------------------
197
198 -- There are four kinds of things on the stack:
199 --
200 -- - pointer variables (bound in the environment)
201 -- - non-pointer variables (bound in the environment)
202 -- - free slots (recorded in the stack free list)
203 -- - non-pointer data slots (recorded in the stack free list)
204 --
205 -- The first two are represented with a 'Just' of a 'LocalReg'.
206 -- The last two with one or more 'Nothing' constructors.
207 -- Each 'Nothing' represents one used word.
208 --
209 -- The head of the stack layout is the top of the stack and
210 -- the least-significant bit.
211
212 -- TODO: refactor to use utility functions
213 -- TODO: combine with CgCallConv.mkLiveness (see comment there)
214 mkLiveness :: Unique
215 -> [Maybe LocalReg]
216 -> (CmmLit, [RawCmmTop], ClosureTypeTag)
217 -- ^ Returns:
218 -- 1. The bitmap (literal value or label)
219 -- 2. Large bitmap CmmData if needed
220 -- 3. rET_SMALL or rET_BIG
221 mkLiveness uniq live =
222 if length bits > mAX_SMALL_BITMAP_SIZE
223 -- does not fit in one word
224 then (CmmLabel big_liveness, [data_lits], rET_BIG)
225 -- fits in one word
226 else (mkWordCLit small_liveness, [], rET_SMALL)
227 where
228 mkBits [] = []
229 mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
230 sizeW = case reg of
231 Nothing -> 1
232 Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1)
233 `quot` wORD_SIZE
234 -- number of words, rounded up
235 bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
236
237 is_non_ptr Nothing = True
238 is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
239
240 bits :: [Bool]
241 bits = mkBits live
242
243 bitmap :: Bitmap
244 bitmap = mkBitmap bits
245
246 small_bitmap = case bitmap of
247 [] -> 0
248 [b] -> fromIntegral b
249 _ -> panic "mkLiveness"
250 small_liveness =
251 fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
252
253 big_liveness = mkBitmapLabel uniq
254 lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
255 data_lits = mkRODataLits big_liveness lits
256
257 -------------------------------------------------------------------------
258 --
259 -- Generating a standard info table
260 --
261 -------------------------------------------------------------------------
262
263 -- The standard bits of an info table. This part of the info table
264 -- corresponds to the StgInfoTable type defined in InfoTables.h.
265 --
266 -- Its shape varies with ticky/profiling/tables next to code etc
267 -- so we can't use constant offsets from Constants
268
269 mkStdInfoTable
270 :: CmmLit -- closure type descr (profiling)
271 -> CmmLit -- closure descr (profiling)
272 -> StgHalfWord -- closure type
273 -> StgHalfWord -- SRT length
274 -> CmmLit -- layout field
275 -> [CmmLit]
276
277 mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
278 = -- Parallel revertible-black hole field
279 prof_info
280 -- Ticky info (none at present)
281 -- Debug info (none at present)
282 ++ [layout_lit, type_lit]
283
284 where
285 prof_info
286 | opt_SccProfilingOn = [type_descr, closure_descr]
287 | otherwise = []
288
289 type_lit = packHalfWordsCLit cl_type srt_len
290