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