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