CmmInfo.hs 14.1 KB
Newer Older
Ian Lynagh's avatar
Ian Lynagh committed
1
2
3
4
5
6
7
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

8
module CmmInfo (
9
  mkEmptyContInfoTable,
10
  cmmToRawCmm,
11
  mkInfoTable,
12
13
14
15
) where

#include "HsVersions.h"

16
import OldCmm as Old
17

18
import CmmUtils
19
import CLabel
20
import SMRep
21
import Bitmap
22
23
import Stream (Stream)
import qualified Stream
24
import Hoopl
25

26
import Maybes
27
import DynFlags
28
import Panic
29
import UniqSupply
30
import MonadUtils
31
32
import Util

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
39
40
41
42
43
mkEmptyContInfoTable info_lbl 
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = mkStackRep []
                 , cit_prof = NoProfilingInfo
                 , cit_srt  = NoC_SRT }

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
51
52
53
                  (b,uniqs') -> return (uniqs',b)
                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
       }
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69

-- 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
70
--	See includes/rts/storage/InfoTables.h
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
--
-- 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

88
mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
89
mkInfoTable _ (CmmData sec dat)
90
91
  = return [CmmData sec dat]

92
93
94
95
96
mkInfoTable dflags proc@(CmmProc infos entry_lbl blocks)
  --
  -- in the non-tables-next-to-code case, procs can have at most a
  -- single info table associated with the entry label of the proc.
  --
97
  | not (tablesNextToCode dflags)
98
99
100
101
102
103
104
105
106
  = case topInfoTable proc of   --  must be at most one
      -- no info table
      Nothing ->
         return [CmmProc mapEmpty entry_lbl blocks]

      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
        (top_decls, (std_info, extra_bits)) <-
             mkInfoTableContents dflags info Nothing
        let
107
108
          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
109
110
111
112
113
114
115
        --
        case blocks of
          ListGraph [] ->
              -- No code; only the info table is significant
              -- Use a zero place-holder in place of the
              -- entry-label in the info table
              return (top_decls ++
116
117
                      [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
                                                                rel_extra_bits)])
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
          _nonempty ->
             -- Separately emit info table (with the function entry
             -- point as first entry) and the entry code
             return (top_decls ++
                     [CmmProc mapEmpty entry_lbl blocks,
                      mkDataLits Data info_lbl
                         (CmmLabel entry_lbl : rel_std_info ++ rel_extra_bits)])

  --
  -- With tables-next-to-code, we can have many info tables,
  -- associated with some of the BlockIds of the proc.  For each info
  -- table we need to turn it into CmmStatics, and collect any new
  -- CmmDecls that arise from doing so.
  --
  | otherwise
  = do
    (top_declss, raw_infos) <- unzip `fmap` mapM do_one_info (mapToList infos)
    return (concat top_declss ++
            [CmmProc (mapFromList raw_infos) entry_lbl blocks])

  where
   do_one_info (lbl,itbl) = do
     (top_decls, (std_info, extra_bits)) <-
         mkInfoTableContents dflags itbl Nothing
     let
        info_lbl = cit_lbl itbl
144
145
        rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
        rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
146
147
148
     --
     return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
                              reverse rel_extra_bits ++ rel_std_info))
149
150
151
152
153
154

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

155
mkInfoTableContents :: DynFlags
156
                    -> CmmInfoTable
Simon Peyton Jones's avatar
Simon Peyton Jones committed
157
158
                    -> Maybe StgHalfWord    -- Override default RTS type tag?
                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
159
                               InfoTableContents)	-- Info tbl + extra bits
160

161
mkInfoTableContents dflags
162
                    info@(CmmInfoTable { cit_lbl  = info_lbl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
163
164
165
166
167
                                       , cit_rep  = smrep
                                       , cit_prof = prof
                                       , cit_srt = srt }) 
                    mb_rts_tag
  | RTSRep rts_tag rep <- smrep
168
  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
169
170
171
    -- 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)
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
180
181
182
183
             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)) }
184
185

  | HeapRep _ ptrs nonptrs closure_type <- smrep
186
187
  = do { let layout  = packHalfWordsCLit dflags ptrs nonptrs
       ; (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
194
195
196
197
198
199
200
                                       (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
201
                 	, [RawCmmDecl])	     -- Auxiliary data decls 
202
203
204
205
206
207
208
209
    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
210
      = return (Just 0, Just (mkWordCLit dflags offset), [], [])
211
212
213
         -- Layout known (one free var); we use the layout field for offset

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

    mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
218
      = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
219
220
           ; let fun_type | null liveness_data = aRG_GEN
                          | otherwise          = aRG_GEN_BIG
221
                 extra_bits = [ packHalfWordsCLit dflags fun_type arity
222
223
224
                              , srt_lit, liveness_lit, slow_entry ]
           ; return (Nothing, Nothing, extra_bits, liveness_data) }
      where
225
        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
226
        srt_lit = case srt_label of
227
                    []          -> mkIntCLit dflags 0
228
229
230
231
                    (lit:_rest) -> ASSERT( null _rest ) lit

    mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"

232

233
mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
234

235
236
mkSRTLit :: DynFlags
         -> C_SRT
237
238
         -> ([CmmLit],    -- srt_label, if any
             StgHalfWord) -- srt_bitmap
239
240
mkSRTLit _      NoC_SRT                = ([], 0)
mkSRTLit dflags (C_SRT lbl off bitmap) = ([cmmLabelOffW dflags lbl off], bitmap)
241
242
243
244
245
246
247
248
249
250
251
252
253


-------------------------------------------------------------------------
--
--      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
254
-- and lays them out in memory, producing a list of RawCmmDecl
255
256
257
258
259
260
261
262
263
264
265
266
267
268

-------------------------------------------------------------------------
--
--	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.

269
makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
270
        
271
272
makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
  | tablesNextToCode dflags
273
  = CmmLabelDiffOff lbl info_lbl 0
274
275
makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
  | tablesNextToCode dflags
276
  = CmmLabelDiffOff lbl info_lbl off
277
makeRelativeRefTo _ _ lit = lit
278

279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299

-------------------------------------------------------------------------
--
--		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.

300
mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
Thomas Schilling's avatar
Thomas Schilling committed
301
302
303
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   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
308
309
310
  = do { uniq <- getUniqueUs
       ; let bitmap_lbl = mkBitmapLabel uniq
       ; return (CmmLabel bitmap_lbl, 
                 [mkRODataLits bitmap_lbl lits]) }
311

312
  | otherwise -- Fits in one word
313
  = return (mkWordCLit dflags bitmap_word, [])
314
315
  where
    n_bits = length liveness
316
317

    bitmap :: Bitmap
318
    bitmap = mkBitmap dflags liveness
319
320

    small_bitmap = case bitmap of 
321
322
323
324
		     []  -> 0
                     [b] -> b
		     _   -> panic "mkLiveness"
    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
329
      -- The first word is the size.  The structure must match
      -- StgLargeBitmap in includes/rts/storage/InfoTable.h
330
331
332
333
334
335
336
337

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

-- The standard bits of an info table.  This part of the info table
338
339
-- corresponds to the StgInfoTable type defined in
-- includes/rts/storage/InfoTables.h.
340
341
342
343
344
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
345
346
   :: DynFlags
   -> (CmmLit,CmmLit)	-- Closure type descr and closure descr  (profiling)
347
   -> StgHalfWord	-- Closure RTS tag 
348
349
350
351
   -> StgHalfWord	-- SRT length
   -> CmmLit		-- layout field
   -> [CmmLit]

352
mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
353
354
355
356
357
358
359
360
 = 	-- Parallel revertible-black hole field
    prof_info
	-- Ticky info (none at present)
	-- Debug info (none at present)
 ++ [layout_lit, type_lit]

 where  
    prof_info 
361
362
	| dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
	| otherwise = []
363

364
    type_lit = packHalfWordsCLit dflags cl_type srt_len
365

366
367
368
369
370
371
-------------------------------------------------------------------------
--
--      Making string literals
--
-------------------------------------------------------------------------

372
373
374
mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])
mkProfLits _ (ProfilingInfo td cd)
375
376
377
378
  = 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
379
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
380
381
382
383
newStringLit bytes
  = do { uniq <- getUniqueUs
       ; return (mkByteStringCLit uniq bytes) }