CmmInfo.hs 10.2 KB
Newer Older
1
module CmmInfo (
2
  emptyContInfoTable,
3
  cmmToRawCmm,
4 5
  mkInfoTable,
  mkBareInfoTable
6 7 8 9 10 11 12 13 14 15 16 17 18 19
) where

#include "HsVersions.h"

import Cmm
import CmmUtils

import CLabel

import Bitmap
import ClosureInfo
import CgInfoTbls
import CgCallConv
import CgUtils
20
import SMRep
21
import ZipCfgCmmRep
22 23

import Constants
24
import Panic
25 26
import StaticFlags
import Unique
27
import UniqSupply
28 29 30

import Data.Bits

31 32 33 34 35 36 37
-- When we split at proc points, we need an empty info table.
emptyContInfoTable :: CmmInfo
emptyContInfoTable =
  CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
                                              (ContInfo [] NoC_SRT))
    where zero = CmmInt 0 wordWidth

38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60
cmmToRawCmm :: [Cmm] -> IO [RawCmm]
cmmToRawCmm cmm = do
  info_tbl_uniques <- mkSplitUniqSupply 'i'
  return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
    where
      raw_cmm uniq_supply (Cmm procs) =
          Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs

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

79
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
Ian Lynagh's avatar
Ian Lynagh committed
80
mkInfoTable _    (CmmData sec dat) = [CmmData sec dat]
81
mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
82
    case info of
Thomas Schilling's avatar
Thomas Schilling committed
83
      -- Code without an info table.  Easy.
84
      CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
85

86
      CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
87
          let info_label = entryLblToInfoLbl entry_label
88 89
              ty_prof'   = makeRelativeRefTo info_label ty_prof
              cl_prof'   = makeRelativeRefTo info_label cl_prof
90
          in case type_info of
Thomas Schilling's avatar
Thomas Schilling committed
91
          -- A function entry point.
92
          FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry ->
93 94 95
              mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
                                 arguments blocks
            where
96
              fun_type = argDescrType pap_bitmap
97 98 99
              fun_extra_bits =
                 [packHalfWordsCLit fun_type fun_arity] ++
                 case pap_bitmap of
100
                 ArgGen liveness ->
101
                     (if null srt_label then [mkIntCLit 0] else srt_label) ++
102
                     [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
103
                      makeRelativeRefTo info_label slow_entry]
104
                 _ -> srt_label
105 106 107 108
              std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap
                                        layout
              (srt_label, srt_bitmap) = mkSRTLit info_label srt
              layout = packHalfWordsCLit ptrs nptrs
109

Thomas Schilling's avatar
Thomas Schilling committed
110
          -- A constructor.
111 112 113 114 115 116 117
          ConstrInfo (ptrs, nptrs) con_tag descr ->
              mkInfoTableAndCode info_label std_info [con_name] entry_label
                                 arguments blocks
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
                con_name = makeRelativeRefTo info_label descr
                layout = packHalfWordsCLit ptrs nptrs
Thomas Schilling's avatar
Thomas Schilling committed
118
          -- A thunk.
119 120 121 122 123 124 125
          ThunkInfo (ptrs, nptrs) srt ->
              mkInfoTableAndCode info_label std_info srt_label entry_label
                                 arguments blocks
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout
                (srt_label, srt_bitmap) = mkSRTLit info_label srt
                layout = packHalfWordsCLit ptrs nptrs
126

Thomas Schilling's avatar
Thomas Schilling committed
127
          -- A selector thunk.
Ian Lynagh's avatar
Ian Lynagh committed
128
          ThunkSelectorInfo offset _srt ->
129 130 131 132
              mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
                                 arguments blocks
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
133

134 135 136 137 138 139 140 141 142 143 144 145 146 147
          -- A continuation/return-point.
          ContInfo stack_layout srt ->
              liveness_data ++
              mkInfoTableAndCode info_label std_info srt_label entry_label
                                 arguments blocks
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap
                                          (makeRelativeRefTo info_label liveness_lit)
                (liveness_lit, liveness_data, liveness_tag) =
                    mkLiveness uniq stack_layout
                maybe_big_type_tag = if type_tag == rET_SMALL
                                     then liveness_tag
                                     else type_tag
                (srt_label, srt_bitmap) = mkSRTLit info_label srt
148

149 150 151 152 153 154 155 156 157 158 159
-- Generate a bare info table, not attached to any procedure.
mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
mkBareInfoTable lbl uniq info =
  case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
    [CmmProc d _ _ _] ->
      ASSERT (tablesNextToCode)
      [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
    [CmmData d s]     -> [CmmData d s]
    _ -> panic "mkBareInfoTable expected to produce only data"


160 161 162 163 164 165
-- Handle the differences between tables-next-to-code
-- and not tables-next-to-code
mkInfoTableAndCode :: CLabel
                   -> [CmmLit]
                   -> [CmmLit]
                   -> CLabel
166
                   -> CmmFormals
167
                   -> ListGraph CmmStmt
168
                   -> [RawCmmTop]
169 170
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
171
  = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
172
             entry_lbl args blocks]
173

174
  | ListGraph [] <- blocks -- No code; only the info table is significant
175 176 177 178 179 180
  =		-- Use a zero place-holder in place of the 
		-- entry-label in the info table
    [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]

  | otherwise	-- Separately emit info table (with the function entry 
  =		-- point as first entry) and the entry code 
181
    [CmmProc [] entry_lbl args blocks,
Ian Lynagh's avatar
Ian Lynagh committed
182
     mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
183

184 185 186 187
mkSRTLit :: CLabel
         -> C_SRT
         -> ([CmmLit],    -- srt_label
             StgHalfWord) -- srt_bitmap
Ian Lynagh's avatar
Ian Lynagh committed
188
mkSRTLit _          NoC_SRT = ([], 0)
189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211
mkSRTLit info_label (C_SRT lbl off bitmap) =
    ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)

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

212
-- TODO: refactor to use utility functions
213 214 215
-- TODO: combine with CgCallConv.mkLiveness (see comment there)
mkLiveness :: Unique
           -> [Maybe LocalReg]
Thomas Schilling's avatar
Thomas Schilling committed
216 217 218 219 220
           -> (CmmLit, [RawCmmTop], ClosureTypeTag)
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   2. Large bitmap CmmData if needed
              --   3. rET_SMALL or rET_BIG
221 222 223 224 225
mkLiveness uniq live =
  if length bits > mAX_SMALL_BITMAP_SIZE
    -- does not fit in one word
    then (CmmLabel big_liveness, [data_lits], rET_BIG)
    -- fits in one word
226
    else (mkWordCLit  small_liveness, [], rET_SMALL)
227
  where
228 229 230 231
    mkBits [] = []
    mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
        sizeW = case reg of
                  Nothing -> 1
232
                  Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1)
233 234
                            `quot` wORD_SIZE
                            -- number of words, rounded up
235
        bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
236

237 238
    is_non_ptr Nothing    = True
    is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
239

240 241 242 243 244 245 246
    bits :: [Bool]
    bits = mkBits live

    bitmap :: Bitmap
    bitmap = mkBitmap bits

    small_bitmap = case bitmap of 
247
		   []  -> 0
248
                   [b] -> b
249
		   _   -> panic "mkLiveness"
250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289
    small_liveness =
        fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)

    big_liveness = mkBitmapLabel uniq
    lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
    data_lits = mkRODataLits big_liveness lits

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

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

mkStdInfoTable
   :: CmmLit		-- closure type descr (profiling)
   -> CmmLit		-- closure descr (profiling)
   -> StgHalfWord	-- closure type
   -> StgHalfWord	-- SRT length
   -> CmmLit		-- layout field
   -> [CmmLit]

mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
 = 	-- 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
290