6aa4d6cbfa728355563bf725c1660499cbc58bff
[ghc.git] / compiler / cmm / CmmInfo.hs
1 {-# OPTIONS -fno-warn-tabs #-}
2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and
4 -- detab the module (please do the detabbing in a separate patch). See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
6 -- for details
7
8 module CmmInfo (
9 mkEmptyContInfoTable,
10 cmmToRawCmm,
11 mkInfoTable,
12 srtEscape
13 ) where
14
15 #include "HsVersions.h"
16
17 import OldCmm as Old
18
19 import CmmUtils
20 import CLabel
21 import SMRep
22 import Bitmap
23 import Stream (Stream)
24 import qualified Stream
25 import Hoopl
26
27 import Maybes
28 import DynFlags
29 import Panic
30 import UniqSupply
31 import MonadUtils
32 import Util
33
34 import Data.Bits
35 import Data.Word
36
37 -- When we split at proc points, we need an empty info table.
38 mkEmptyContInfoTable :: CLabel -> CmmInfoTable
39 mkEmptyContInfoTable info_lbl
40 = CmmInfoTable { cit_lbl = info_lbl
41 , cit_rep = mkStackRep []
42 , cit_prof = NoProfilingInfo
43 , cit_srt = NoC_SRT }
44
45 cmmToRawCmm :: DynFlags -> Stream IO Old.CmmGroup ()
46 -> IO (Stream IO Old.RawCmmGroup ())
47 cmmToRawCmm dflags cmms
48 = do { uniqs <- mkSplitUniqSupply 'i'
49 ; let do_one uniqs cmm = do
50 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
51 (b,uniqs') -> return (uniqs',b)
52 -- NB. strictness fixes a space leak. DO NOT REMOVE.
53 ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
54 }
55
56 -- Make a concrete info table, represented as a list of CmmStatic
57 -- (it can't be simply a list of Word, because the SRT field is
58 -- represented by a label+offset expression).
59 --
60 -- With tablesNextToCode, the layout is
61 -- <reversed variable part>
62 -- <normal forward StgInfoTable, but without
63 -- an entry point at the front>
64 -- <code>
65 --
66 -- Without tablesNextToCode, the layout of an info table is
67 -- <entry label>
68 -- <normal forward rest of StgInfoTable>
69 -- <forward variable part>
70 --
71 -- See includes/rts/storage/InfoTables.h
72 --
73 -- For return-points these are as follows
74 --
75 -- Tables next to code:
76 --
77 -- <srt slot>
78 -- <standard info table>
79 -- ret-addr --> <entry code (if any)>
80 --
81 -- Not tables-next-to-code:
82 --
83 -- ret-addr --> <ptr to entry code>
84 -- <standard info table>
85 -- <srt slot>
86 --
87 -- * The SRT slot is only there if there is SRT info to record
88
89 mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
90 mkInfoTable _ (CmmData sec dat)
91 = return [CmmData sec dat]
92
93 mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
94 --
95 -- in the non-tables-next-to-code case, procs can have at most a
96 -- single info table associated with the entry label of the proc.
97 --
98 | not (tablesNextToCode dflags)
99 = case topInfoTable proc of -- must be at most one
100 -- no info table
101 Nothing ->
102 return [CmmProc mapEmpty entry_lbl blocks]
103
104 Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
105 (top_decls, (std_info, extra_bits)) <-
106 mkInfoTableContents dflags info Nothing
107 let
108 rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
109 rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
110 --
111 case blocks of
112 ListGraph [] ->
113 -- No code; only the info table is significant
114 -- Use a zero place-holder in place of the
115 -- entry-label in the info table
116 return (top_decls ++
117 [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
118 rel_extra_bits)])
119 _nonempty ->
120 -- Separately emit info table (with the function entry
121 -- point as first entry) and the entry code
122 return (top_decls ++
123 [CmmProc mapEmpty entry_lbl blocks,
124 mkDataLits Data info_lbl
125 (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
126
127 --
128 -- With tables-next-to-code, we can have many info tables,
129 -- associated with some of the BlockIds of the proc. For each info
130 -- table we need to turn it into CmmStatics, and collect any new
131 -- CmmDecls that arise from doing so.
132 --
133 | otherwise
134 = do
135 (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
136 return (concat top_declss ++
137 [CmmProc (mapFromList raw_infos) entry_lbl blocks])
138
139 where
140 do_one_info (lbl,itbl) = do
141 (top_decls, (std_info, extra_bits)) <-
142 mkInfoTableContents dflags itbl Nothing
143 let
144 info_lbl = cit_lbl itbl
145 rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
146 rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
147 --
148 return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
149 reverse rel_extra_bits ++ rel_std_info))
150
151 -----------------------------------------------------
152 type InfoTableContents = ( [CmmLit] -- The standard part
153 , [CmmLit] ) -- The "extra bits"
154 -- These Lits have *not* had mkRelativeTo applied to them
155
156 mkInfoTableContents :: DynFlags
157 -> CmmInfoTable
158 -> Maybe StgHalfWord -- Override default RTS type tag?
159 -> UniqSM ([RawCmmDecl], -- Auxiliary top decls
160 InfoTableContents) -- Info tbl + extra bits
161
162 mkInfoTableContents dflags
163 info@(CmmInfoTable { cit_lbl = info_lbl
164 , cit_rep = smrep
165 , cit_prof = prof
166 , cit_srt = srt })
167 mb_rts_tag
168 | RTSRep rts_tag rep <- smrep
169 = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
170 -- Completely override the rts_tag that mkInfoTableContents would
171 -- otherwise compute, with the rts_tag stored in the RTSRep
172 -- (which in turn came from a handwritten .cmm file)
173
174 | StackRep frame <- smrep
175 = do { (prof_lits, prof_data) <- mkProfLits dflags prof
176 ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
177 ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
178 ; let
179 std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
180 rts_tag | Just tag <- mb_rts_tag = tag
181 | null liveness_data = rET_SMALL dflags -- Fits in extra_bits
182 | otherwise = rET_BIG dflags -- Does not; extra_bits is
183 -- a label
184 ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
185
186 | HeapRep _ ptrs nonptrs closure_type <- smrep
187 = do { let layout = packHalfWordsCLit
188 dflags
189 (toStgHalfWord dflags (toInteger ptrs))
190 (toStgHalfWord dflags (toInteger nonptrs))
191 ; (prof_lits, prof_data) <- mkProfLits dflags prof
192 ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
193 ; (mb_srt_field, mb_layout, extra_bits, ct_data)
194 <- mk_pieces closure_type srt_label
195 ; let std_info = mkStdInfoTable dflags prof_lits
196 (mb_rts_tag `orElse` rtsClosureType dflags smrep)
197 (mb_srt_field `orElse` srt_bitmap)
198 (mb_layout `orElse` layout)
199 ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
200 where
201 mk_pieces :: ClosureTypeInfo -> [CmmLit]
202 -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this
203 , Maybe CmmLit -- Override the layout field with this
204 , [CmmLit] -- "Extra bits" for info table
205 , [RawCmmDecl]) -- Auxiliary data decls
206 mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
207 = do { (descr_lit, decl) <- newStringLit con_descr
208 ; return (Just con_tag, Nothing, [descr_lit], [decl]) }
209
210 mk_pieces Thunk srt_label
211 = return (Nothing, Nothing, srt_label, [])
212
213 mk_pieces (ThunkSelector offset) _no_srt
214 = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], [])
215 -- Layout known (one free var); we use the layout field for offset
216
217 mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
218 = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label
219 ; return (Nothing, Nothing, extra_bits, []) }
220
221 mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
222 = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
223 ; let fun_type | null liveness_data = aRG_GEN dflags
224 | otherwise = aRG_GEN_BIG dflags
225 extra_bits = [ packHalfWordsCLit dflags fun_type arity
226 , srt_lit, liveness_lit, slow_entry ]
227 ; return (Nothing, Nothing, extra_bits, liveness_data) }
228 where
229 slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
230 srt_lit = case srt_label of
231 [] -> mkIntCLit dflags 0
232 (lit:_rest) -> ASSERT( null _rest ) lit
233
234 mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
235
236
237 mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
238
239 mkSRTLit :: DynFlags
240 -> C_SRT
241 -> ([CmmLit], -- srt_label, if any
242 StgHalfWord) -- srt_bitmap
243 mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0)
244 mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
245
246
247 -------------------------------------------------------------------------
248 --
249 -- Lay out the info table and handle relative offsets
250 --
251 -------------------------------------------------------------------------
252
253 -- This function takes
254 -- * the standard info table portion (StgInfoTable)
255 -- * the "extra bits" (StgFunInfoExtraRev etc.)
256 -- * the entry label
257 -- * the code
258 -- and lays them out in memory, producing a list of RawCmmDecl
259
260 -------------------------------------------------------------------------
261 --
262 -- Position independent code
263 --
264 -------------------------------------------------------------------------
265 -- In order to support position independent code, we mustn't put absolute
266 -- references into read-only space. Info tables in the tablesNextToCode
267 -- case must be in .text, which is read-only, so we doctor the CmmLits
268 -- to use relative offsets instead.
269
270 -- Note that this is done even when the -fPIC flag is not specified,
271 -- as we want to keep binary compatibility between PIC and non-PIC.
272
273 makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
274
275 makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
276 | tablesNextToCode dflags
277 = CmmLabelDiffOff lbl info_lbl 0
278 makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
279 | tablesNextToCode dflags
280 = CmmLabelDiffOff lbl info_lbl off
281 makeRelativeRefTo _ _ lit = lit
282
283
284 -------------------------------------------------------------------------
285 --
286 -- Build a liveness mask for the stack layout
287 --
288 -------------------------------------------------------------------------
289
290 -- There are four kinds of things on the stack:
291 --
292 -- - pointer variables (bound in the environment)
293 -- - non-pointer variables (bound in the environment)
294 -- - free slots (recorded in the stack free list)
295 -- - non-pointer data slots (recorded in the stack free list)
296 --
297 -- The first two are represented with a 'Just' of a 'LocalReg'.
298 -- The last two with one or more 'Nothing' constructors.
299 -- Each 'Nothing' represents one used word.
300 --
301 -- The head of the stack layout is the top of the stack and
302 -- the least-significant bit.
303
304 mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
305 -- ^ Returns:
306 -- 1. The bitmap (literal value or label)
307 -- 2. Large bitmap CmmData if needed
308
309 mkLivenessBits dflags liveness
310 | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
311 = do { uniq <- getUniqueUs
312 ; let bitmap_lbl = mkBitmapLabel uniq
313 ; return (CmmLabel bitmap_lbl,
314 [mkRODataLits bitmap_lbl lits]) }
315
316 | otherwise -- Fits in one word
317 = return (mkWordCLit dflags bitmap_word, [])
318 where
319 n_bits = length liveness
320
321 bitmap :: Bitmap
322 bitmap = mkBitmap dflags liveness
323
324 small_bitmap = case bitmap of
325 [] -> toStgWord dflags 0
326 [b] -> b
327 _ -> panic "mkLiveness"
328 bitmap_word = toStgWord dflags (fromIntegral n_bits)
329 .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
330
331 lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap
332 -- The first word is the size. The structure must match
333 -- StgLargeBitmap in includes/rts/storage/InfoTable.h
334
335 -------------------------------------------------------------------------
336 --
337 -- Generating a standard info table
338 --
339 -------------------------------------------------------------------------
340
341 -- The standard bits of an info table. This part of the info table
342 -- corresponds to the StgInfoTable type defined in
343 -- includes/rts/storage/InfoTables.h.
344 --
345 -- Its shape varies with ticky/profiling/tables next to code etc
346 -- so we can't use constant offsets from Constants
347
348 mkStdInfoTable
349 :: DynFlags
350 -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
351 -> StgHalfWord -- Closure RTS tag
352 -> StgHalfWord -- SRT length
353 -> CmmLit -- layout field
354 -> [CmmLit]
355
356 mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
357 = -- Parallel revertible-black hole field
358 prof_info
359 -- Ticky info (none at present)
360 -- Debug info (none at present)
361 ++ [layout_lit, type_lit]
362
363 where
364 prof_info
365 | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
366 | otherwise = []
367
368 type_lit = packHalfWordsCLit dflags cl_type srt_len
369
370 -------------------------------------------------------------------------
371 --
372 -- Making string literals
373 --
374 -------------------------------------------------------------------------
375
376 mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
377 mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
378 mkProfLits _ (ProfilingInfo td cd)
379 = do { (td_lit, td_decl) <- newStringLit td
380 ; (cd_lit, cd_decl) <- newStringLit cd
381 ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
382
383 newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
384 newStringLit bytes
385 = do { uniq <- getUniqueUs
386 ; return (mkByteStringCLit uniq bytes) }
387
388
389 -- Misc utils
390
391 -- | Value of the srt field of an info table when using an StgLargeSRT
392 srtEscape :: DynFlags -> StgHalfWord
393 srtEscape dflags = toStgHalfWord dflags (-1)