b9981f247b5402391c9acef7a96b499cd23b0e5f
[ghc.git] / compiler / cmm / CmmInfo.hs
1 {-# LANGUAGE CPP #-}
2 module CmmInfo (
3 mkEmptyContInfoTable,
4 cmmToRawCmm,
5 mkInfoTable,
6 srtEscape,
7
8 -- info table accessors
9 closureInfoPtr,
10 entryCode,
11 getConstrTag,
12 cmmGetClosureType,
13 infoTable,
14 infoTableConstrTag,
15 infoTableSrtBitmap,
16 infoTableClosureType,
17 infoTablePtrs,
18 infoTableNonPtrs,
19 funInfoTable,
20 funInfoArity,
21
22 -- info table sizes and offsets
23 stdInfoTableSizeW,
24 fixedInfoTableSizeW,
25 profInfoTableSizeW,
26 maxStdInfoTableSizeW,
27 maxRetInfoTableSizeW,
28 stdInfoTableSizeB,
29 conInfoTableSizeB,
30 stdSrtBitmapOffset,
31 stdClosureTypeOffset,
32 stdPtrsOffset, stdNonPtrsOffset,
33 ) where
34
35 #include "HsVersions.h"
36
37 import Cmm
38 import CmmUtils
39 import CLabel
40 import SMRep
41 import Bitmap
42 import Stream (Stream)
43 import qualified Stream
44 import Hoopl
45
46 import Maybes
47 import DynFlags
48 import Panic
49 import UniqSupply
50 import MonadUtils
51 import Util
52 import Outputable
53
54 import Data.Bits
55 import Data.Word
56
57 -- When we split at proc points, we need an empty info table.
58 mkEmptyContInfoTable :: CLabel -> CmmInfoTable
59 mkEmptyContInfoTable info_lbl
60 = CmmInfoTable { cit_lbl = info_lbl
61 , cit_rep = mkStackRep []
62 , cit_prof = NoProfilingInfo
63 , cit_srt = NoC_SRT }
64
65 cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
66 -> IO (Stream IO RawCmmGroup ())
67 cmmToRawCmm dflags cmms
68 = do { uniqs <- mkSplitUniqSupply 'i'
69 ; let do_one uniqs cmm = do
70 case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
71 (b,uniqs') -> return (uniqs',b)
72 -- NB. strictness fixes a space leak. DO NOT REMOVE.
73 ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
74 }
75
76 -- Make a concrete info table, represented as a list of CmmStatic
77 -- (it can't be simply a list of Word, because the SRT field is
78 -- represented by a label+offset expression).
79 --
80 -- With tablesNextToCode, the layout is
81 -- <reversed variable part>
82 -- <normal forward StgInfoTable, but without
83 -- an entry point at the front>
84 -- <code>
85 --
86 -- Without tablesNextToCode, the layout of an info table is
87 -- <entry label>
88 -- <normal forward rest of StgInfoTable>
89 -- <forward variable part>
90 --
91 -- See includes/rts/storage/InfoTables.h
92 --
93 -- For return-points these are as follows
94 --
95 -- Tables next to code:
96 --
97 -- <srt slot>
98 -- <standard info table>
99 -- ret-addr --> <entry code (if any)>
100 --
101 -- Not tables-next-to-code:
102 --
103 -- ret-addr --> <ptr to entry code>
104 -- <standard info table>
105 -- <srt slot>
106 --
107 -- * The SRT slot is only there if there is SRT info to record
108
109 mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
110 mkInfoTable _ (CmmData sec dat)
111 = return [CmmData sec dat]
112
113 mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
114 --
115 -- in the non-tables-next-to-code case, procs can have at most a
116 -- single info table associated with the entry label of the proc.
117 --
118 | not (tablesNextToCode dflags)
119 = case topInfoTable proc of -- must be at most one
120 -- no info table
121 Nothing ->
122 return [CmmProc mapEmpty entry_lbl live blocks]
123
124 Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
125 (top_decls, (std_info, extra_bits)) <-
126 mkInfoTableContents dflags info Nothing
127 let
128 rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
129 rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
130 --
131 -- Separately emit info table (with the function entry
132 -- point as first entry) and the entry code
133 --
134 return (top_decls ++
135 [CmmProc mapEmpty entry_lbl live blocks,
136 mkDataLits (Section Data info_lbl) info_lbl
137 (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])
138
139 --
140 -- With tables-next-to-code, we can have many info tables,
141 -- associated with some of the BlockIds of the proc. For each info
142 -- table we need to turn it into CmmStatics, and collect any new
143 -- CmmDecls that arise from doing so.
144 --
145 | otherwise
146 = do
147 (top_declss, raw_infos) <-
148 unzip `fmap` mapM do_one_info (mapToList (info_tbls infos))
149 return (concat top_declss ++
150 [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
151
152 where
153 do_one_info (lbl,itbl) = do
154 (top_decls, (std_info, extra_bits)) <-
155 mkInfoTableContents dflags itbl Nothing
156 let
157 info_lbl = cit_lbl itbl
158 rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
159 rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
160 --
161 return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
162 reverse rel_extra_bits ++ rel_std_info))
163
164 -----------------------------------------------------
165 type InfoTableContents = ( [CmmLit] -- The standard part
166 , [CmmLit] ) -- The "extra bits"
167 -- These Lits have *not* had mkRelativeTo applied to them
168
169 mkInfoTableContents :: DynFlags
170 -> CmmInfoTable
171 -> Maybe Int -- Override default RTS type tag?
172 -> UniqSM ([RawCmmDecl], -- Auxiliary top decls
173 InfoTableContents) -- Info tbl + extra bits
174
175 mkInfoTableContents dflags
176 info@(CmmInfoTable { cit_lbl = info_lbl
177 , cit_rep = smrep
178 , cit_prof = prof
179 , cit_srt = srt })
180 mb_rts_tag
181 | RTSRep rts_tag rep <- smrep
182 = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
183 -- Completely override the rts_tag that mkInfoTableContents would
184 -- otherwise compute, with the rts_tag stored in the RTSRep
185 -- (which in turn came from a handwritten .cmm file)
186
187 | StackRep frame <- smrep
188 = do { (prof_lits, prof_data) <- mkProfLits dflags prof
189 ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
190 ; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
191 ; let
192 std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
193 rts_tag | Just tag <- mb_rts_tag = tag
194 | null liveness_data = rET_SMALL -- Fits in extra_bits
195 | otherwise = rET_BIG -- Does not; extra_bits is
196 -- a label
197 ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
198
199 | HeapRep _ ptrs nonptrs closure_type <- smrep
200 = do { let layout = packIntsCLit dflags ptrs nonptrs
201 ; (prof_lits, prof_data) <- mkProfLits dflags prof
202 ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
203 ; (mb_srt_field, mb_layout, extra_bits, ct_data)
204 <- mk_pieces closure_type srt_label
205 ; let std_info = mkStdInfoTable dflags prof_lits
206 (mb_rts_tag `orElse` rtsClosureType smrep)
207 (mb_srt_field `orElse` srt_bitmap)
208 (mb_layout `orElse` layout)
209 ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
210 where
211 mk_pieces :: ClosureTypeInfo -> [CmmLit]
212 -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this
213 , Maybe CmmLit -- Override the layout field with this
214 , [CmmLit] -- "Extra bits" for info table
215 , [RawCmmDecl]) -- Auxiliary data decls
216 mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
217 = do { (descr_lit, decl) <- newStringLit con_descr
218 ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))
219 , Nothing, [descr_lit], [decl]) }
220
221 mk_pieces Thunk srt_label
222 = return (Nothing, Nothing, srt_label, [])
223
224 mk_pieces (ThunkSelector offset) _no_srt
225 = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])
226 -- Layout known (one free var); we use the layout field for offset
227
228 mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
229 = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
230 ; return (Nothing, Nothing, extra_bits, []) }
231
232 mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
233 = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
234 ; let fun_type | null liveness_data = aRG_GEN
235 | otherwise = aRG_GEN_BIG
236 extra_bits = [ packIntsCLit dflags fun_type arity
237 , srt_lit, liveness_lit, slow_entry ]
238 ; return (Nothing, Nothing, extra_bits, liveness_data) }
239 where
240 slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
241 srt_lit = case srt_label of
242 [] -> mkIntCLit dflags 0
243 (lit:_rest) -> ASSERT( null _rest ) lit
244
245 mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
246
247 mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
248
249 packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
250 packIntsCLit dflags a b = packHalfWordsCLit dflags
251 (toStgHalfWord dflags (fromIntegral a))
252 (toStgHalfWord dflags (fromIntegral b))
253
254
255 mkSRTLit :: DynFlags
256 -> C_SRT
257 -> ([CmmLit], -- srt_label, if any
258 StgHalfWord) -- srt_bitmap
259 mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0)
260 mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
261
262
263 -------------------------------------------------------------------------
264 --
265 -- Lay out the info table and handle relative offsets
266 --
267 -------------------------------------------------------------------------
268
269 -- This function takes
270 -- * the standard info table portion (StgInfoTable)
271 -- * the "extra bits" (StgFunInfoExtraRev etc.)
272 -- * the entry label
273 -- * the code
274 -- and lays them out in memory, producing a list of RawCmmDecl
275
276 -------------------------------------------------------------------------
277 --
278 -- Position independent code
279 --
280 -------------------------------------------------------------------------
281 -- In order to support position independent code, we mustn't put absolute
282 -- references into read-only space. Info tables in the tablesNextToCode
283 -- case must be in .text, which is read-only, so we doctor the CmmLits
284 -- to use relative offsets instead.
285
286 -- Note that this is done even when the -fPIC flag is not specified,
287 -- as we want to keep binary compatibility between PIC and non-PIC.
288
289 makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
290
291 makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
292 | tablesNextToCode dflags
293 = CmmLabelDiffOff lbl info_lbl 0
294 makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
295 | tablesNextToCode dflags
296 = CmmLabelDiffOff lbl info_lbl off
297 makeRelativeRefTo _ _ lit = lit
298
299
300 -------------------------------------------------------------------------
301 --
302 -- Build a liveness mask for the stack layout
303 --
304 -------------------------------------------------------------------------
305
306 -- There are four kinds of things on the stack:
307 --
308 -- - pointer variables (bound in the environment)
309 -- - non-pointer variables (bound in the environment)
310 -- - free slots (recorded in the stack free list)
311 -- - non-pointer data slots (recorded in the stack free list)
312 --
313 -- The first two are represented with a 'Just' of a 'LocalReg'.
314 -- The last two with one or more 'Nothing' constructors.
315 -- Each 'Nothing' represents one used word.
316 --
317 -- The head of the stack layout is the top of the stack and
318 -- the least-significant bit.
319
320 mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
321 -- ^ Returns:
322 -- 1. The bitmap (literal value or label)
323 -- 2. Large bitmap CmmData if needed
324
325 mkLivenessBits dflags liveness
326 | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
327 = do { uniq <- getUniqueM
328 ; let bitmap_lbl = mkBitmapLabel uniq
329 ; return (CmmLabel bitmap_lbl,
330 [mkRODataLits bitmap_lbl lits]) }
331
332 | otherwise -- Fits in one word
333 = return (mkStgWordCLit dflags bitmap_word, [])
334 where
335 n_bits = length liveness
336
337 bitmap :: Bitmap
338 bitmap = mkBitmap dflags liveness
339
340 small_bitmap = case bitmap of
341 [] -> toStgWord dflags 0
342 [b] -> b
343 _ -> panic "mkLiveness"
344 bitmap_word = toStgWord dflags (fromIntegral n_bits)
345 .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
346
347 lits = mkWordCLit dflags (fromIntegral n_bits)
348 : map (mkStgWordCLit dflags) bitmap
349 -- The first word is the size. The structure must match
350 -- StgLargeBitmap in includes/rts/storage/InfoTable.h
351
352 -------------------------------------------------------------------------
353 --
354 -- Generating a standard info table
355 --
356 -------------------------------------------------------------------------
357
358 -- The standard bits of an info table. This part of the info table
359 -- corresponds to the StgInfoTable type defined in
360 -- includes/rts/storage/InfoTables.h.
361 --
362 -- Its shape varies with ticky/profiling/tables next to code etc
363 -- so we can't use constant offsets from Constants
364
365 mkStdInfoTable
366 :: DynFlags
367 -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
368 -> Int -- Closure RTS tag
369 -> StgHalfWord -- SRT length
370 -> CmmLit -- layout field
371 -> [CmmLit]
372
373 mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
374 = -- Parallel revertible-black hole field
375 prof_info
376 -- Ticky info (none at present)
377 -- Debug info (none at present)
378 ++ [layout_lit, type_lit]
379
380 where
381 prof_info
382 | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
383 | otherwise = []
384
385 type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len
386
387 -------------------------------------------------------------------------
388 --
389 -- Making string literals
390 --
391 -------------------------------------------------------------------------
392
393 mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
394 mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
395 mkProfLits _ (ProfilingInfo td cd)
396 = do { (td_lit, td_decl) <- newStringLit td
397 ; (cd_lit, cd_decl) <- newStringLit cd
398 ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
399
400 newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
401 newStringLit bytes
402 = do { uniq <- getUniqueM
403 ; return (mkByteStringCLit uniq bytes) }
404
405
406 -- Misc utils
407
408 -- | Value of the srt field of an info table when using an StgLargeSRT
409 srtEscape :: DynFlags -> StgHalfWord
410 srtEscape dflags = toStgHalfWord dflags (-1)
411
412 -------------------------------------------------------------------------
413 --
414 -- Accessing fields of an info table
415 --
416 -------------------------------------------------------------------------
417
418 closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
419 -- Takes a closure pointer and returns the info table pointer
420 closureInfoPtr dflags e = CmmLoad e (bWord dflags)
421
422 entryCode :: DynFlags -> CmmExpr -> CmmExpr
423 -- Takes an info pointer (the first word of a closure)
424 -- and returns its entry code
425 entryCode dflags e
426 | tablesNextToCode dflags = e
427 | otherwise = CmmLoad e (bWord dflags)
428
429 getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
430 -- Takes a closure pointer, and return the *zero-indexed*
431 -- constructor tag obtained from the info table
432 -- This lives in the SRT field of the info table
433 -- (constructors don't need SRTs).
434 getConstrTag dflags closure_ptr
435 = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
436 where
437 info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
438
439 cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
440 -- Takes a closure pointer, and return the closure type
441 -- obtained from the info table
442 cmmGetClosureType dflags closure_ptr
443 = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
444 where
445 info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
446
447 infoTable :: DynFlags -> CmmExpr -> CmmExpr
448 -- Takes an info pointer (the first word of a closure)
449 -- and returns a pointer to the first word of the standard-form
450 -- info table, excluding the entry-code word (if present)
451 infoTable dflags info_ptr
452 | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
453 | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
454
455 infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
456 -- Takes an info table pointer (from infoTable) and returns the constr tag
457 -- field of the info table (same as the srt_bitmap field)
458 infoTableConstrTag = infoTableSrtBitmap
459
460 infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
461 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
462 -- field of the info table
463 infoTableSrtBitmap dflags info_tbl
464 = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
465
466 infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
467 -- Takes an info table pointer (from infoTable) and returns the closure type
468 -- field of the info table.
469 infoTableClosureType dflags info_tbl
470 = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
471
472 infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
473 infoTablePtrs dflags info_tbl
474 = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
475
476 infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
477 infoTableNonPtrs dflags info_tbl
478 = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
479
480 funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
481 -- Takes the info pointer of a function,
482 -- and returns a pointer to the first word of the StgFunInfoExtra struct
483 -- in the info table.
484 funInfoTable dflags info_ptr
485 | tablesNextToCode dflags
486 = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
487 | otherwise
488 = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
489 -- Past the entry code pointer
490
491 -- Takes the info pointer of a function, returns the function's arity
492 funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
493 funInfoArity dflags iptr
494 = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
495 where
496 fun_info = funInfoTable dflags iptr
497 rep = cmmBits (widthFromBytes rep_bytes)
498
499 (rep_bytes, offset)
500 | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc
501 , oFFSET_StgFunInfoExtraRev_arity dflags )
502 | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
503 , oFFSET_StgFunInfoExtraFwd_arity dflags )
504
505 pc = sPlatformConstants (settings dflags)
506
507 -----------------------------------------------------------------------------
508 --
509 -- Info table sizes & offsets
510 --
511 -----------------------------------------------------------------------------
512
513 stdInfoTableSizeW :: DynFlags -> WordOff
514 -- The size of a standard info table varies with profiling/ticky etc,
515 -- so we can't get it from Constants
516 -- It must vary in sync with mkStdInfoTable
517 stdInfoTableSizeW dflags
518 = fixedInfoTableSizeW
519 + if gopt Opt_SccProfilingOn dflags
520 then profInfoTableSizeW
521 else 0
522
523 fixedInfoTableSizeW :: WordOff
524 fixedInfoTableSizeW = 2 -- layout, type
525
526 profInfoTableSizeW :: WordOff
527 profInfoTableSizeW = 2
528
529 maxStdInfoTableSizeW :: WordOff
530 maxStdInfoTableSizeW =
531 1 {- entry, when !tablesNextToCode -}
532 + fixedInfoTableSizeW
533 + profInfoTableSizeW
534
535 maxRetInfoTableSizeW :: WordOff
536 maxRetInfoTableSizeW =
537 maxStdInfoTableSizeW
538 + 1 {- srt label -}
539
540 stdInfoTableSizeB :: DynFlags -> ByteOff
541 stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
542
543 stdSrtBitmapOffset :: DynFlags -> ByteOff
544 -- Byte offset of the SRT bitmap half-word which is
545 -- in the *higher-addressed* part of the type_lit
546 stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
547
548 stdClosureTypeOffset :: DynFlags -> ByteOff
549 -- Byte offset of the closure type half-word
550 stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
551
552 stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
553 stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
554 stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
555
556 conInfoTableSizeB :: DynFlags -> Int
557 conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags