CmmInfo.hs 12.7 KB
Newer Older
1
module CmmInfo (
2
  mkEmptyContInfoTable,
3
  cmmToRawCmm,
4
  mkInfoTable,
5
6
7
8
) where

#include "HsVersions.h"

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 StaticFlags
20
import UniqSupply
21
import MonadUtils
22
import Data.Bits
23
import Data.Word
24

25
-- When we split at proc points, we need an empty info table.
26
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
27
28
29
30
31
32
mkEmptyContInfoTable info_lbl 
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = mkStackRep []
                 , cit_prof = NoProfilingInfo
                 , cit_srt  = NoC_SRT }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
33
cmmToRawCmm :: [Old.CmmGroup] -> IO [Old.RawCmmGroup]
34
35
36
cmmToRawCmm cmms
  = do { uniqs <- mkSplitUniqSupply 'i'
       ; return (initUs_ uniqs (mapM (concatMapM mkInfoTable) cmms)) }
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52

-- Make a concrete info table, represented as a list of CmmStatic
-- (it can't be simply a list of Word, because the SRT field is
-- represented by a label+offset expression).
--
-- With tablesNextToCode, the layout is
--	<reversed variable part>
--	<normal forward StgInfoTable, but without 
--		an entry point at the front>
--	<code>
--
-- Without tablesNextToCode, the layout of an info table is
--	<entry label>
--	<normal forward rest of StgInfoTable>
--	<forward variable part>
--
Simon Marlow's avatar
Simon Marlow committed
53
--	See includes/rts/storage/InfoTables.h
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
--
-- For return-points these are as follows
--
-- Tables next to code:
--
--			<srt slot>
--			<standard info table>
--  	ret-addr -->	<entry code (if any)>
--
-- Not tables-next-to-code:
--
--	ret-addr -->	<ptr to entry code>
--			<standard info table>
--			<srt slot>
--
--  * The SRT slot is only there if there is SRT info to record

Simon Peyton Jones's avatar
Simon Peyton Jones committed
71
mkInfoTable :: CmmDecl -> UniqSM [RawCmmDecl]
72
73
74
75
76
77
78
79
mkInfoTable (CmmData sec dat) 
  = return [CmmData sec dat]

mkInfoTable (CmmProc (CmmInfo _ _ info) entry_label blocks)
  | CmmNonInfoTable <- info   -- Code without an info table.  Easy.
  = return [CmmProc Nothing entry_label blocks]
                               
  | CmmInfoTable { cit_lbl = info_lbl } <- info
80
  = do { (top_decls, info_cts) <- mkInfoTableContents info Nothing
81
82
83
84
85
86
87
88
89
90
91
       ; return (top_decls  ++
                 mkInfoTableAndCode info_lbl info_cts
                                    entry_label blocks) }
  | otherwise = panic "mkInfoTable"  -- Patern match overlap check not clever enough

-----------------------------------------------------
type InfoTableContents = ( [CmmLit]	     -- The standard part
                         , [CmmLit] )	     -- The "extra bits"
-- These Lits have *not* had mkRelativeTo applied to them

mkInfoTableContents :: CmmInfoTable
Simon Peyton Jones's avatar
Simon Peyton Jones committed
92
93
                    -> Maybe StgHalfWord    -- Override default RTS type tag?
                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
94
                               InfoTableContents)	-- Info tbl + extra bits
95

Simon Peyton Jones's avatar
Simon Peyton Jones committed
96
97
98
99
100
101
102
103
104
105
mkInfoTableContents info@(CmmInfoTable { cit_lbl  = info_lbl
                                       , cit_rep  = smrep
                                       , cit_prof = prof
                                       , cit_srt = srt }) 
                    mb_rts_tag
  | RTSRep rts_tag rep <- smrep
  = mkInfoTableContents info{cit_rep = rep} (Just rts_tag)
    -- Completely override the rts_tag that mkInfoTableContents would
    -- otherwise compute, with the rts_tag stored in the RTSRep
    -- (which in turn came from a handwritten .cmm file)
106

107
  | StackRep frame <- smrep
108
109
  = do { (prof_lits, prof_data) <- mkProfLits prof
       ; let (srt_label, srt_bitmap) = mkSRTLit srt
110
       ; (liveness_lit, liveness_data) <- mkLivenessBits frame
111
       ; let
112
             std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
113
114
115
116
117
             rts_tag | Just tag <- mb_rts_tag = tag
                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
                     | otherwise              = rET_BIG   -- Does not; extra_bits is
                                                          -- a label
       ; return (prof_data ++ liveness_data, (std_info, srt_label)) }
118
119

  | HeapRep _ ptrs nonptrs closure_type <- smrep
120
  = do { let layout  = packHalfWordsCLit ptrs nonptrs
121
       ; (prof_lits, prof_data) <- mkProfLits prof
122
123
       ; let (srt_label, srt_bitmap) = mkSRTLit srt
       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
124
                                <- mk_pieces closure_type srt_label
125
126
       ; let std_info = mkStdInfoTable prof_lits
                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
127
128
129
130
131
132
133
134
                                       (mb_srt_field `orElse` srt_bitmap)
                                       (mb_layout    `orElse` layout)
       ; return (prof_data ++ ct_data, (std_info, extra_bits)) }
  where
    mk_pieces :: ClosureTypeInfo -> [CmmLit]
              -> UniqSM ( Maybe StgHalfWord  -- Override the SRT field with this
                 	, Maybe CmmLit       -- Override the layout field with this
                 	, [CmmLit]           -- "Extra bits" for info table
Simon Peyton Jones's avatar
Simon Peyton Jones committed
135
                 	, [RawCmmDecl])	     -- Auxiliary data decls 
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
      = do { (descr_lit, decl) <- newStringLit con_descr
      	   ; return (Just con_tag, Nothing, [descr_lit], [decl]) }

    mk_pieces Thunk srt_label
      = return (Nothing, Nothing, srt_label, [])

    mk_pieces (ThunkSelector offset) _no_srt
      = return (Just 0, Just (mkWordCLit offset), [], [])
         -- Layout known (one free var); we use the layout field for offset

    mk_pieces (Fun arity (ArgSpec fun_type)) srt_label 
      = do { let extra_bits = packHalfWordsCLit fun_type arity : srt_label
           ; return (Nothing, Nothing,  extra_bits, []) }

    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
      = do { (liveness_lit, liveness_data) <- mkLivenessBits arg_bits
           ; let fun_type | null liveness_data = aRG_GEN
                          | otherwise          = aRG_GEN_BIG
                 extra_bits = [ packHalfWordsCLit fun_type arity
                              , srt_lit, liveness_lit, slow_entry ]
           ; return (Nothing, Nothing, extra_bits, liveness_data) }
      where
        slow_entry = CmmLabel (slowEntryFromInfoLabel info_lbl)
        srt_lit = case srt_label of
                    []          -> mkIntCLit 0
                    (lit:_rest) -> ASSERT( null _rest ) lit

    mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"

166
167

mkInfoTableContents _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186

mkSRTLit :: C_SRT
         -> ([CmmLit],    -- srt_label, if any
             StgHalfWord) -- srt_bitmap
mkSRTLit NoC_SRT                = ([], 0)
mkSRTLit (C_SRT lbl off bitmap) = ([cmmLabelOffW lbl off], bitmap)


-------------------------------------------------------------------------
--
--      Lay out the info table and handle relative offsets
--
-------------------------------------------------------------------------

-- This function takes
--   * the standard info table portion (StgInfoTable)
--   * the "extra bits" (StgFunInfoExtraRev etc.)
--   * the entry label
--   * the code
Simon Peyton Jones's avatar
Simon Peyton Jones committed
187
-- and lays them out in memory, producing a list of RawCmmDecl
188
189
190
191
192
193
194
195
196
197
198

-- The value of tablesNextToCode determines the relative positioning
-- of the extra bits and the standard info table, and whether the
-- former is reversed or not.  It also decides whether pointers in the
-- info table should be expressed as offsets relative to the info
-- pointer or not (see "Position Independent Code" below.

mkInfoTableAndCode :: CLabel             -- Info table label
                   -> InfoTableContents
                   -> CLabel     	 -- Entry label
                   -> ListGraph CmmStmt  -- Entry code
Simon Peyton Jones's avatar
Simon Peyton Jones committed
199
                   -> [RawCmmDecl]
200
mkInfoTableAndCode info_lbl (std_info, extra_bits) entry_lbl blocks
201
  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
202
203
  = [CmmProc (Just $ Statics info_lbl $ map CmmStaticLit $
                     reverse rel_extra_bits ++ rel_std_info)
204
             entry_lbl blocks]
205

206
  | ListGraph [] <- blocks -- No code; only the info table is significant
207
208
  =		-- Use a zero place-holder in place of the 
		-- entry-label in the info table
209
    [mkRODataLits info_lbl (zeroCLit : rel_std_info ++ rel_extra_bits)]
210
211
212

  | otherwise	-- Separately emit info table (with the function entry 
  =		-- point as first entry) and the entry code 
213
    [CmmProc Nothing entry_lbl blocks,
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
     mkDataLits Data info_lbl (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)]
  where
    rel_std_info   = map (makeRelativeRefTo info_lbl) std_info
    rel_extra_bits = map (makeRelativeRefTo info_lbl) extra_bits

-------------------------------------------------------------------------
--
--	Position independent code
--
-------------------------------------------------------------------------
-- In order to support position independent code, we mustn't put absolute
-- references into read-only space. Info tables in the tablesNextToCode
-- case must be in .text, which is read-only, so we doctor the CmmLits
-- to use relative offsets instead.

-- Note that this is done even when the -fPIC flag is not specified,
-- as we want to keep binary compatibility between PIC and non-PIC.

makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
        
makeRelativeRefTo info_lbl (CmmLabel lbl)
  | tablesNextToCode
  = CmmLabelDiffOff lbl info_lbl 0
makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
  | tablesNextToCode
  = CmmLabelDiffOff lbl info_lbl off
makeRelativeRefTo _ lit = lit
241

242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262

-------------------------------------------------------------------------
--
--		Build a liveness mask for the stack layout
--
-------------------------------------------------------------------------

-- There are four kinds of things on the stack:
--
--	- pointer variables (bound in the environment)
-- 	- non-pointer variables (bound in the environment)
-- 	- free slots (recorded in the stack free list)
-- 	- non-pointer data slots (recorded in the stack free list)
--
-- The first two are represented with a 'Just' of a 'LocalReg'.
-- The last two with one or more 'Nothing' constructors.
-- Each 'Nothing' represents one used word.
--
-- The head of the stack layout is the top of the stack and
-- the least-significant bit.

Simon Peyton Jones's avatar
Simon Peyton Jones committed
263
mkLivenessBits :: Liveness -> UniqSM (CmmLit, [RawCmmDecl])
Thomas Schilling's avatar
Thomas Schilling committed
264
265
266
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   2. Large bitmap CmmData if needed
267

268
269
270
271
272
273
mkLivenessBits liveness
  | n_bits > mAX_SMALL_BITMAP_SIZE    -- does not fit in one word
  = do { uniq <- getUniqueUs
       ; let bitmap_lbl = mkBitmapLabel uniq
       ; return (CmmLabel bitmap_lbl, 
                 [mkRODataLits bitmap_lbl lits]) }
274

275
276
277
278
  | otherwise -- Fits in one word
  = return (mkWordCLit bitmap_word, [])
  where
    n_bits = length liveness
279
280

    bitmap :: Bitmap
281
    bitmap = mkBitmap liveness
282
283

    small_bitmap = case bitmap of 
284
285
286
287
288
		     []  -> 0
                     [b] -> b
		     _   -> panic "mkLiveness"
    bitmap_word = fromIntegral n_bits
              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
289

290
291
292
    lits = mkWordCLit (fromIntegral n_bits) : map mkWordCLit bitmap
      -- The first word is the size.  The structure must match
      -- StgLargeBitmap in includes/rts/storage/InfoTable.h
293
294
295
296
297
298
299
300

-------------------------------------------------------------------------
--
--	Generating a standard info table
--
-------------------------------------------------------------------------

-- The standard bits of an info table.  This part of the info table
301
302
-- corresponds to the StgInfoTable type defined in
-- includes/rts/storage/InfoTables.h.
303
304
305
306
307
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
308
309
   :: (CmmLit,CmmLit)	-- Closure type descr and closure descr  (profiling)
   -> StgHalfWord	-- Closure RTS tag 
310
311
312
313
   -> StgHalfWord	-- SRT length
   -> CmmLit		-- layout field
   -> [CmmLit]

314
mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
315
316
317
318
319
320
321
322
323
324
325
326
 = 	-- Parallel revertible-black hole field
    prof_info
	-- Ticky info (none at present)
	-- Debug info (none at present)
 ++ [layout_lit, type_lit]

 where  
    prof_info 
	| opt_SccProfilingOn = [type_descr, closure_descr]
	| otherwise	     = []

    type_lit = packHalfWordsCLit cl_type srt_len
327

328
329
330
331
332
333
-------------------------------------------------------------------------
--
--      Making string literals
--
-------------------------------------------------------------------------

Simon Peyton Jones's avatar
Simon Peyton Jones committed
334
mkProfLits :: ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
335
336
337
338
339
340
mkProfLits NoProfilingInfo       = return ((zeroCLit, zeroCLit), [])
mkProfLits (ProfilingInfo td cd)
  = do { (td_lit, td_decl) <- newStringLit td
       ; (cd_lit, cd_decl) <- newStringLit cd
       ; return ((td_lit,cd_lit), [td_decl,cd_decl]) }

Simon Peyton Jones's avatar
Simon Peyton Jones committed
341
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
342
343
344
345
newStringLit bytes
  = do { uniq <- getUniqueUs
       ; return (mkByteStringCLit uniq bytes) }