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