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