Make StgHalfWord a portable type
[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 dflags -- Fits in extra_bits
181 | otherwise = rET_BIG dflags -- 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
187 dflags
188 (toStgHalfWord dflags (toInteger ptrs))
189 (toStgHalfWord dflags (toInteger nonptrs))
190 ; (prof_lits, prof_data) <- mkProfLits dflags prof
191 ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt
192 ; (mb_srt_field, mb_layout, extra_bits, ct_data)
193 <- mk_pieces closure_type srt_label
194 ; let std_info = mkStdInfoTable dflags prof_lits
195 (mb_rts_tag `orElse` rtsClosureType dflags smrep)
196 (mb_srt_field `orElse` srt_bitmap)
197 (mb_layout `orElse` layout)
198 ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
199 where
200 mk_pieces :: ClosureTypeInfo -> [CmmLit]
201 -> UniqSM ( Maybe StgHalfWord -- Override the SRT field with this
202 , Maybe CmmLit -- Override the layout field with this
203 , [CmmLit] -- "Extra bits" for info table
204 , [RawCmmDecl]) -- Auxiliary data decls
205 mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
206 = do { (descr_lit, decl) <- newStringLit con_descr
207 ; return (Just con_tag, Nothing, [descr_lit], [decl]) }
208
209 mk_pieces Thunk srt_label
210 = return (Nothing, Nothing, srt_label, [])
211
212 mk_pieces (ThunkSelector offset) _no_srt
213 = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], [])
214 -- Layout known (one free var); we use the layout field for offset
215
216 mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
217 = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label
218 ; return (Nothing, Nothing, extra_bits, []) }
219
220 mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
221 = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
222 ; let fun_type | null liveness_data = aRG_GEN dflags
223 | otherwise = aRG_GEN_BIG dflags
224 extra_bits = [ packHalfWordsCLit dflags fun_type arity
225 , srt_lit, liveness_lit, slow_entry ]
226 ; return (Nothing, Nothing, extra_bits, liveness_data) }
227 where
228 slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
229 srt_lit = case srt_label of
230 [] -> mkIntCLit dflags 0
231 (lit:_rest) -> ASSERT( null _rest ) lit
232
233 mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
234
235
236 mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
237
238 mkSRTLit :: DynFlags
239 -> C_SRT
240 -> ([CmmLit], -- srt_label, if any
241 StgHalfWord) -- srt_bitmap
242 mkSRTLit dflags NoC_SRT = ([], toStgHalfWord dflags 0)
243 mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
244
245
246 -------------------------------------------------------------------------
247 --
248 -- Lay out the info table and handle relative offsets
249 --
250 -------------------------------------------------------------------------
251
252 -- This function takes
253 -- * the standard info table portion (StgInfoTable)
254 -- * the "extra bits" (StgFunInfoExtraRev etc.)
255 -- * the entry label
256 -- * the code
257 -- and lays them out in memory, producing a list of RawCmmDecl
258
259 -------------------------------------------------------------------------
260 --
261 -- Position independent code
262 --
263 -------------------------------------------------------------------------
264 -- In order to support position independent code, we mustn't put absolute
265 -- references into read-only space. Info tables in the tablesNextToCode
266 -- case must be in .text, which is read-only, so we doctor the CmmLits
267 -- to use relative offsets instead.
268
269 -- Note that this is done even when the -fPIC flag is not specified,
270 -- as we want to keep binary compatibility between PIC and non-PIC.
271
272 makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
273
274 makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
275 | tablesNextToCode dflags
276 = CmmLabelDiffOff lbl info_lbl 0
277 makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
278 | tablesNextToCode dflags
279 = CmmLabelDiffOff lbl info_lbl off
280 makeRelativeRefTo _ _ lit = lit
281
282
283 -------------------------------------------------------------------------
284 --
285 -- Build a liveness mask for the stack layout
286 --
287 -------------------------------------------------------------------------
288
289 -- There are four kinds of things on the stack:
290 --
291 -- - pointer variables (bound in the environment)
292 -- - non-pointer variables (bound in the environment)
293 -- - free slots (recorded in the stack free list)
294 -- - non-pointer data slots (recorded in the stack free list)
295 --
296 -- The first two are represented with a 'Just' of a 'LocalReg'.
297 -- The last two with one or more 'Nothing' constructors.
298 -- Each 'Nothing' represents one used word.
299 --
300 -- The head of the stack layout is the top of the stack and
301 -- the least-significant bit.
302
303 mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
304 -- ^ Returns:
305 -- 1. The bitmap (literal value or label)
306 -- 2. Large bitmap CmmData if needed
307
308 mkLivenessBits dflags liveness
309 | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
310 = do { uniq <- getUniqueUs
311 ; let bitmap_lbl = mkBitmapLabel uniq
312 ; return (CmmLabel bitmap_lbl,
313 [mkRODataLits bitmap_lbl lits]) }
314
315 | otherwise -- Fits in one word
316 = return (mkWordCLit dflags bitmap_word, [])
317 where
318 n_bits = length liveness
319
320 bitmap :: Bitmap
321 bitmap = mkBitmap dflags liveness
322
323 small_bitmap = case bitmap of
324 [] -> 0
325 [b] -> b
326 _ -> panic "mkLiveness"
327 bitmap_word = fromIntegral n_bits
328 .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
329
330 lits = mkWordCLit dflags (fromIntegral n_bits) : map (mkWordCLit dflags) bitmap
331 -- The first word is the size. The structure must match
332 -- StgLargeBitmap in includes/rts/storage/InfoTable.h
333
334 -------------------------------------------------------------------------
335 --
336 -- Generating a standard info table
337 --
338 -------------------------------------------------------------------------
339
340 -- The standard bits of an info table. This part of the info table
341 -- corresponds to the StgInfoTable type defined in
342 -- includes/rts/storage/InfoTables.h.
343 --
344 -- Its shape varies with ticky/profiling/tables next to code etc
345 -- so we can't use constant offsets from Constants
346
347 mkStdInfoTable
348 :: DynFlags
349 -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling)
350 -> StgHalfWord -- Closure RTS tag
351 -> StgHalfWord -- SRT length
352 -> CmmLit -- layout field
353 -> [CmmLit]
354
355 mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
356 = -- Parallel revertible-black hole field
357 prof_info
358 -- Ticky info (none at present)
359 -- Debug info (none at present)
360 ++ [layout_lit, type_lit]
361
362 where
363 prof_info
364 | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
365 | otherwise = []
366
367 type_lit = packHalfWordsCLit dflags cl_type srt_len
368
369 -------------------------------------------------------------------------
370 --
371 -- Making string literals
372 --
373 -------------------------------------------------------------------------
374
375 mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
376 mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
377 mkProfLits _ (ProfilingInfo td cd)
378 = do { (td_lit, td_decl) <- newStringLit td
379 ; (cd_lit, cd_decl) <- newStringLit cd
380 ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
381
382 newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
383 newStringLit bytes
384 = do { uniq <- getUniqueUs
385 ; return (mkByteStringCLit uniq bytes) }
386