CmmInfo.hs 14.7 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 94 95 96 97
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.
  --
98
  | not (tablesNextToCode dflags)
99 100 101 102 103 104 105 106 107
  = 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
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 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144
          _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
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 
369 370
	| dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
	| 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)