CmmInfo.hs 13.2 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 Maybes
24
import Constants
25
import Panic
26
import Platform
27
import StaticFlags
28
import UniqSupply
29
import MonadUtils
30
31
import Util

32
import Data.Bits
33
import Data.Word
34

35
-- When we split at proc points, we need an empty info table.
36
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
37
38
39
40
41
42
mkEmptyContInfoTable info_lbl 
  = CmmInfoTable { cit_lbl  = info_lbl
                 , cit_rep  = mkStackRep []
                 , cit_prof = NoProfilingInfo
                 , cit_srt  = NoC_SRT }

43
44
cmmToRawCmm :: Platform -> [Old.CmmGroup] -> IO [Old.RawCmmGroup]
cmmToRawCmm platform cmms
45
  = do { uniqs <- mkSplitUniqSupply 'i'
46
       ; return (initUs_ uniqs (mapM (concatMapM (mkInfoTable platform)) cmms)) }
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

-- 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
63
--	See includes/rts/storage/InfoTables.h
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
--
-- 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

81
82
mkInfoTable :: Platform -> CmmDecl -> UniqSM [RawCmmDecl]
mkInfoTable _ (CmmData sec dat) 
83
84
  = return [CmmData sec dat]

85
mkInfoTable platform (CmmProc (CmmInfo _ _ info) entry_label blocks)
86
87
88
89
  | CmmNonInfoTable <- info   -- Code without an info table.  Easy.
  = return [CmmProc Nothing entry_label blocks]
                               
  | CmmInfoTable { cit_lbl = info_lbl } <- info
90
  = do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing
91
92
93
94
95
96
97
98
99
100
       ; 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

101
102
mkInfoTableContents :: Platform
                    -> CmmInfoTable
Simon Peyton Jones's avatar
Simon Peyton Jones committed
103
104
                    -> Maybe StgHalfWord    -- Override default RTS type tag?
                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
105
                               InfoTableContents)	-- Info tbl + extra bits
106

107
108
mkInfoTableContents platform
                    info@(CmmInfoTable { cit_lbl  = info_lbl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
109
110
111
112
113
                                       , cit_rep  = smrep
                                       , cit_prof = prof
                                       , cit_srt = srt }) 
                    mb_rts_tag
  | RTSRep rts_tag rep <- smrep
114
  = mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
115
116
117
    -- 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)
118

119
  | StackRep frame <- smrep
120
121
  = do { (prof_lits, prof_data) <- mkProfLits prof
       ; let (srt_label, srt_bitmap) = mkSRTLit srt
122
       ; (liveness_lit, liveness_data) <- mkLivenessBits frame
123
       ; let
124
             std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
125
126
127
128
129
             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)) }
130
131

  | HeapRep _ ptrs nonptrs closure_type <- smrep
132
  = do { let layout  = packHalfWordsCLit ptrs nonptrs
133
       ; (prof_lits, prof_data) <- mkProfLits prof
134
135
       ; let (srt_label, srt_bitmap) = mkSRTLit srt
       ; (mb_srt_field, mb_layout, extra_bits, ct_data)
136
                                <- mk_pieces closure_type srt_label
137
138
       ; let std_info = mkStdInfoTable prof_lits
                                       (mb_rts_tag   `orElse` rtsClosureType smrep)
139
140
141
142
143
144
145
146
                                       (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
147
                 	, [RawCmmDecl])	     -- Auxiliary data decls 
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
    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
171
        slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
172
173
174
175
176
177
        srt_lit = case srt_label of
                    []          -> mkIntCLit 0
                    (lit:_rest) -> ASSERT( null _rest ) lit

    mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"

178

179
mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198

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
199
-- and lays them out in memory, producing a list of RawCmmDecl
200
201
202
203
204
205
206
207
208
209
210

-- 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
211
                   -> [RawCmmDecl]
212
mkInfoTableAndCode info_lbl (std_info, extra_bits) entry_lbl blocks
213
  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
214
215
  = [CmmProc (Just $ Statics info_lbl $ map CmmStaticLit $
                     reverse rel_extra_bits ++ rel_std_info)
216
             entry_lbl blocks]
217

218
  | ListGraph [] <- blocks -- No code; only the info table is significant
219
220
  =		-- Use a zero place-holder in place of the 
		-- entry-label in the info table
221
    [mkRODataLits info_lbl (zeroCLit : rel_std_info ++ rel_extra_bits)]
222
223
224

  | otherwise	-- Separately emit info table (with the function entry 
  =		-- point as first entry) and the entry code 
225
    [CmmProc Nothing entry_lbl blocks,
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
     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
253

254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274

-------------------------------------------------------------------------
--
--		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
275
mkLivenessBits :: Liveness -> UniqSM (CmmLit, [RawCmmDecl])
Thomas Schilling's avatar
Thomas Schilling committed
276
277
278
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   2. Large bitmap CmmData if needed
279

280
281
282
283
284
285
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]) }
286

287
288
289
290
  | otherwise -- Fits in one word
  = return (mkWordCLit bitmap_word, [])
  where
    n_bits = length liveness
291
292

    bitmap :: Bitmap
293
    bitmap = mkBitmap liveness
294
295

    small_bitmap = case bitmap of 
296
297
298
299
300
		     []  -> 0
                     [b] -> b
		     _   -> panic "mkLiveness"
    bitmap_word = fromIntegral n_bits
              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
301

302
303
304
    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
305
306
307
308
309
310
311
312

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

-- The standard bits of an info table.  This part of the info table
313
314
-- corresponds to the StgInfoTable type defined in
-- includes/rts/storage/InfoTables.h.
315
316
317
318
319
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
320
321
   :: (CmmLit,CmmLit)	-- Closure type descr and closure descr  (profiling)
   -> StgHalfWord	-- Closure RTS tag 
322
323
324
325
   -> StgHalfWord	-- SRT length
   -> CmmLit		-- layout field
   -> [CmmLit]

326
mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
327
328
329
330
331
332
333
334
335
336
337
338
 = 	-- 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
339

340
341
342
343
344
345
-------------------------------------------------------------------------
--
--      Making string literals
--
-------------------------------------------------------------------------

Simon Peyton Jones's avatar
Simon Peyton Jones committed
346
mkProfLits :: ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
347
348
349
350
351
352
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
353
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
354
355
356
357
newStringLit bytes
  = do { uniq <- getUniqueUs
       ; return (mkByteStringCLit uniq bytes) }