CmmInfo.hs 14.8 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,
Simon Marlow's avatar
Simon Marlow committed
12
  srtEscape
13
14
15
16
) where

#include "HsVersions.h"

17
import OldCmm as Old
18

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

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

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

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

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

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

93
mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
94
95
96
97
  --
  -- 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.
  --
98
  | not (tablesNextToCode dflags)
99
100
101
  = case topInfoTable proc of   --  must be at most one
      -- no info table
      Nothing ->
102
         return [CmmProc mapEmpty entry_lbl live blocks]
103
104
105
106
107

      Just info@CmmInfoTable { cit_lbl = info_lbl } -> do
        (top_decls, (std_info, extra_bits)) <-
             mkInfoTableContents dflags info Nothing
        let
108
109
          rel_std_info   = map (makeRelativeRefTo dflags info_lbl) std_info
          rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
110
111
112
113
114
115
116
        --
        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 ++
117
118
                      [mkRODataLits info_lbl (zeroCLit dflags : rel_std_info ++
                                                                rel_extra_bits)])
119
120
121
122
          _nonempty ->
             -- Separately emit info table (with the function entry
             -- point as first entry) and the entry code
             return (top_decls ++
123
                     [CmmProc mapEmpty entry_lbl live blocks,
124
125
126
127
128
129
130
131
132
133
134
135
136
                      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 ++
137
            [CmmProc (mapFromList raw_infos) entry_lbl live blocks])
138
139
140
141
142
143
144

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

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

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

162
mkInfoTableContents dflags
163
                    info@(CmmInfoTable { cit_lbl  = info_lbl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
164
165
166
167
168
                                       , cit_rep  = smrep
                                       , cit_prof = prof
                                       , cit_srt = srt }) 
                    mb_rts_tag
  | RTSRep rts_tag rep <- smrep
169
  = mkInfoTableContents dflags info{cit_rep = rep} (Just rts_tag)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
170
171
172
    -- 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)
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
182
183
                     | null liveness_data     = rET_SMALL -- Fits in extra_bits
                     | otherwise              = rET_BIG   -- Does not; extra_bits is
                                                          -- 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
195
196
197
198
199
200
201
                                       (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
202
                 	, [RawCmmDecl])	     -- Auxiliary data decls 
203
204
    mk_pieces (Constr con_tag con_descr) _no_srt    -- A data constructor
      = do { (descr_lit, decl) <- newStringLit con_descr
205
206
           ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag))
                    , Nothing, [descr_lit], [decl]) }
207
208
209
210
211

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

    mk_pieces (ThunkSelector offset) _no_srt
212
      = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], [])
213
214
215
         -- Layout known (one free var); we use the layout field for offset

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

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

    mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"

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

236
237
238
239
240
241
packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
packIntsCLit dflags a b = packHalfWordsCLit dflags
                           (toStgHalfWord dflags (fromIntegral a))
                           (toStgHalfWord dflags (fromIntegral b))


242
243
mkSRTLit :: DynFlags
         -> C_SRT
244
245
         -> ([CmmLit],    -- srt_label, if any
             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
253
254
255
256
257
258
259
260


-------------------------------------------------------------------------
--
--      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
261
-- and lays them out in memory, producing a list of RawCmmDecl
262
263
264
265
266
267
268
269
270
271
272
273
274
275

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

276
makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
277
        
278
279
makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
  | tablesNextToCode dflags
280
  = CmmLabelDiffOff lbl info_lbl 0
281
282
makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
  | tablesNextToCode dflags
283
  = CmmLabelDiffOff lbl info_lbl off
284
makeRelativeRefTo _ _ lit = lit
285

286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306

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

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

319
  | otherwise -- Fits in one word
320
  = return (mkStgWordCLit dflags bitmap_word, [])
321
322
  where
    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
330
                     [b] -> b
		     _   -> panic "mkLiveness"
331
    bitmap_word = toStgWord dflags (fromIntegral n_bits)
332
              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
333

334
335
    lits = mkWordCLit dflags (fromIntegral n_bits)
         : map (mkStgWordCLit dflags) bitmap
336
337
      -- The first word is the size.  The structure must match
      -- StgLargeBitmap in includes/rts/storage/InfoTable.h
338
339
340
341
342
343
344
345

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

-- The standard bits of an info table.  This part of the info table
346
347
-- corresponds to the StgInfoTable type defined in
-- includes/rts/storage/InfoTables.h.
348
349
350
351
352
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
353
354
   :: DynFlags
   -> (CmmLit,CmmLit)	-- Closure type descr and closure descr  (profiling)
355
356
   -> Int               -- Closure RTS tag
   -> StgHalfWord       -- SRT length
357
358
359
   -> CmmLit		-- layout field
   -> [CmmLit]

360
mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit
361
362
363
364
365
366
367
368
 = 	-- Parallel revertible-black hole field
    prof_info
	-- Ticky info (none at present)
	-- Debug info (none at present)
 ++ [layout_lit, type_lit]

 where  
    prof_info 
ian@well-typed.com's avatar
ian@well-typed.com committed
369
	| gopt 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
377
378
379
-------------------------------------------------------------------------
--
--      Making string literals
--
-------------------------------------------------------------------------

380
381
382
mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
mkProfLits dflags NoProfilingInfo       = return ((zeroCLit dflags, zeroCLit dflags), [])
mkProfLits _ (ProfilingInfo td cd)
383
384
385
386
  = 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
387
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
388
389
390
391
newStringLit bytes
  = do { uniq <- getUniqueUs
       ; return (mkByteStringCLit uniq bytes) }

Simon Marlow's avatar
Simon Marlow committed
392
393
394
395
396
397

-- Misc utils

-- | Value of the srt field of an info table when using an StgLargeSRT
srtEscape :: DynFlags -> StgHalfWord
srtEscape dflags = toStgHalfWord dflags (-1)