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