CmmInfo.hs 13.5 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

25
import Maybes
26
import Constants
27
import Panic
28
import Platform
29
import StaticFlags
30
import UniqSupply
31
import MonadUtils
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 -> Stream IO Old.CmmGroup ()
            -> IO (Stream IO Old.RawCmmGroup ())
45
cmmToRawCmm platform cmms
46
  = do { uniqs <- mkSplitUniqSupply 'i'
47 48 49 50 51 52
       ; let do_one uniqs cmm = do
                case initUs uniqs $ concatMapM (mkInfoTable platform) cmm of
                  (b,uniqs') -> return (uniqs',b)
                  -- NB. strictness fixes a space leak.  DO NOT REMOVE.
       ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
       }
53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68

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

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

Simon Marlow's avatar
Simon Marlow committed
91
mkInfoTable platform (CmmProc info entry_label blocks)
92 93 94 95
  | CmmNonInfoTable <- info   -- Code without an info table.  Easy.
  = return [CmmProc Nothing entry_label blocks]
                               
  | CmmInfoTable { cit_lbl = info_lbl } <- info
96
  = do { (top_decls, info_cts) <- mkInfoTableContents platform info Nothing
97 98 99
       ; return (top_decls  ++
                 mkInfoTableAndCode info_lbl info_cts
                                    entry_label blocks) }
Simon Marlow's avatar
Simon Marlow committed
100 101
  | otherwise = panic "mkInfoTable"
                  -- Patern match overlap check not clever enough
102 103 104 105 106 107

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

108 109
mkInfoTableContents :: Platform
                    -> CmmInfoTable
Simon Peyton Jones's avatar
Simon Peyton Jones committed
110 111
                    -> Maybe StgHalfWord    -- Override default RTS type tag?
                    -> UniqSM ([RawCmmDecl],             -- Auxiliary top decls
112
                               InfoTableContents)	-- Info tbl + extra bits
113

114 115
mkInfoTableContents platform
                    info@(CmmInfoTable { cit_lbl  = info_lbl
Simon Peyton Jones's avatar
Simon Peyton Jones committed
116 117 118 119 120
                                       , cit_rep  = smrep
                                       , cit_prof = prof
                                       , cit_srt = srt }) 
                    mb_rts_tag
  | RTSRep rts_tag rep <- smrep
121
  = mkInfoTableContents platform info{cit_rep = rep} (Just rts_tag)
Simon Peyton Jones's avatar
Simon Peyton Jones committed
122 123 124
    -- 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)
125

126
  | StackRep frame <- smrep
127 128
  = do { (prof_lits, prof_data) <- mkProfLits prof
       ; let (srt_label, srt_bitmap) = mkSRTLit srt
129
       ; (liveness_lit, liveness_data) <- mkLivenessBits frame
130
       ; let
131
             std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
132 133 134 135 136
             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)) }
137 138

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

    mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"

185

186
mkInfoTableContents _ _ _ = panic "mkInfoTableContents"   -- NonInfoTable dealt with earlier
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205

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
206
-- and lays them out in memory, producing a list of RawCmmDecl
207 208 209 210 211 212 213 214 215 216 217

-- 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
218
                   -> [RawCmmDecl]
219
mkInfoTableAndCode info_lbl (std_info, extra_bits) entry_lbl blocks
220
  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
221 222
  = [CmmProc (Just $ Statics info_lbl $ map CmmStaticLit $
                     reverse rel_extra_bits ++ rel_std_info)
223
             entry_lbl blocks]
224

225
  | ListGraph [] <- blocks -- No code; only the info table is significant
226 227
  =		-- Use a zero place-holder in place of the 
		-- entry-label in the info table
228
    [mkRODataLits info_lbl (zeroCLit : rel_std_info ++ rel_extra_bits)]
229 230 231

  | otherwise	-- Separately emit info table (with the function entry 
  =		-- point as first entry) and the entry code 
232
    [CmmProc Nothing entry_lbl blocks,
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259
     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
260

261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281

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

287 288 289 290 291 292
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]) }
293

294 295 296 297
  | otherwise -- Fits in one word
  = return (mkWordCLit bitmap_word, [])
  where
    n_bits = length liveness
298 299

    bitmap :: Bitmap
300
    bitmap = mkBitmap liveness
301 302

    small_bitmap = case bitmap of 
303 304 305 306 307
		     []  -> 0
                     [b] -> b
		     _   -> panic "mkLiveness"
    bitmap_word = fromIntegral n_bits
              .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
308

309 310 311
    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
312 313 314 315 316 317 318 319

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

-- The standard bits of an info table.  This part of the info table
320 321
-- corresponds to the StgInfoTable type defined in
-- includes/rts/storage/InfoTables.h.
322 323 324 325 326
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
327 328
   :: (CmmLit,CmmLit)	-- Closure type descr and closure descr  (profiling)
   -> StgHalfWord	-- Closure RTS tag 
329 330 331 332
   -> StgHalfWord	-- SRT length
   -> CmmLit		-- layout field
   -> [CmmLit]

333
mkStdInfoTable (type_descr, closure_descr) cl_type srt_len layout_lit
334 335 336 337 338 339 340 341 342 343 344 345
 = 	-- 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
346

347 348 349 350 351 352
-------------------------------------------------------------------------
--
--      Making string literals
--
-------------------------------------------------------------------------

Simon Peyton Jones's avatar
Simon Peyton Jones committed
353
mkProfLits :: ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
354 355 356 357 358 359
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
360
newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
361 362 363 364
newStringLit bytes
  = do { uniq <- getUniqueUs
       ; return (mkByteStringCLit uniq bytes) }