compiler/cmm/CmmInfo.hs

   1 module CmmInfo (
   2   emptyContInfoTable,
   3   cmmToRawCmm,
   4   mkInfoTable,
   5   mkBareInfoTable
   6 ) where
   7
   8 #include "HsVersions.h"
   9
  10 import Cmm
  11 import CmmUtils
  12
  13 import CLabel
  14
  15 import Bitmap
  16 import ClosureInfo
  17 import CgInfoTbls
  18 import CgCallConv
  19 import CgUtils
  20 import SMRep
  21 import ZipCfgCmmRep
  22
  23 import Constants
  24 import Panic
  25 import StaticFlags
  26 import Unique
  27 import UniqSupply
  28
  29 import Data.Bits
  30
  31 -- When we split at proc points, we need an empty info table.
  32 emptyContInfoTable :: CmmInfo
  33 emptyContInfoTable =
  34   CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
  35                                               (ContInfo [] NoC_SRT))
  36     where zero = CmmInt 0 wordWidth
  37
  38 cmmToRawCmm :: [Cmm] -> IO [RawCmm]
  39 cmmToRawCmm cmm = do
  40   info_tbl_uniques <- mkSplitUniqSupply 'i'
  41   return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
  42     where
  43       raw_cmm uniq_supply (Cmm procs) =
  44           Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs
  45
  46 -- Make a concrete info table, represented as a list of CmmStatic
  47 -- (it can't be simply a list of Word, because the SRT field is
  48 -- represented by a label+offset expression).
  49 --
  50 -- With tablesNextToCode, the layout is
  51 --      <reversed variable part>
  52 --      <normal forward StgInfoTable, but without
  53 --              an entry point at the front>
  54 --      <code>
  55 --
  56 -- Without tablesNextToCode, the layout of an info table is
  57 --      <entry label>
  58 --      <normal forward rest of StgInfoTable>
  59 --      <forward variable part>
  60 --
  61 --      See includes/InfoTables.h
  62 --
  63 -- For return-points these are as follows
  64 --
  65 -- Tables next to code:
  66 --
  67 --                      <srt slot>
  68 --                      <standard info table>
  69 --      ret-addr -->    <entry code (if any)>
  70 --
  71 -- Not tables-next-to-code:
  72 --
  73 --      ret-addr -->    <ptr to entry code>
  74 --                      <standard info table>
  75 --                      <srt slot>
  76 --
  77 --  * The SRT slot is only there if there is SRT info to record
  78
  79 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
  80 mkInfoTable _    (CmmData sec dat) = [CmmData sec dat]
  81 mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
  82     case info of
  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               ty_prof'   = makeRelativeRefTo info_label ty_prof
  89               cl_prof'   = makeRelativeRefTo info_label cl_prof
  90           in case type_info of
  91           -- A function entry point.
  92           FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry ->
  93               mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
  94                                  arguments blocks
  95             where
  96               fun_type = argDescrType pap_bitmap
  97               fun_extra_bits =
  98                  [packHalfWordsCLit fun_type fun_arity] ++
  99                  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               std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap
 106                                         layout
 107               (srt_label, srt_bitmap) = mkSRTLit info_label srt
 108               layout = packHalfWordsCLit ptrs nptrs
 109
 110           -- A constructor.
 111           ConstrInfo (ptrs, nptrs) con_tag descr ->
 112               mkInfoTableAndCode info_label std_info [con_name] entry_label
 113                                  arguments blocks
 114               where
 115                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
 116                 con_name = makeRelativeRefTo info_label descr
 117                 layout = packHalfWordsCLit ptrs nptrs
 118           -- A thunk.
 119           ThunkInfo (ptrs, nptrs) srt ->
 120               mkInfoTableAndCode info_label std_info srt_label entry_label
 121                                  arguments blocks
 122               where
 123                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout
 124                 (srt_label, srt_bitmap) = mkSRTLit info_label srt
 125                 layout = packHalfWordsCLit ptrs nptrs
 126
 127           -- A selector thunk.
 128           ThunkSelectorInfo offset _srt ->
 129               mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
 130                                  arguments blocks
 131               where
 132                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
 133
 134           -- A continuation/return-point.
 135           ContInfo stack_layout srt ->
 136               liveness_data ++
 137               mkInfoTableAndCode info_label std_info srt_label entry_label
 138                                  arguments blocks
 139               where
 140                 std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap
 141                                           (makeRelativeRefTo info_label liveness_lit)
 142                 (liveness_lit, liveness_data, liveness_tag) =
 143                     mkLiveness uniq stack_layout
 144                 maybe_big_type_tag = if type_tag == rET_SMALL
 145                                      then liveness_tag
 146                                      else type_tag
 147                 (srt_label, srt_bitmap) = mkSRTLit info_label srt
 148
 149 -- Generate a bare info table, not attached to any procedure.
 150 mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
 151 mkBareInfoTable lbl uniq info =
 152   case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
 153     [CmmProc d _ _ _] ->
 154       ASSERT (tablesNextToCode)
 155       [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
 156     [CmmData d s]     -> [CmmData d s]
 157     _ -> panic "mkBareInfoTable expected to produce only data"
 158
 159
 160 -- Handle the differences between tables-next-to-code
 161 -- and not tables-next-to-code
 162 mkInfoTableAndCode :: CLabel
 163                    -> [CmmLit]
 164                    -> [CmmLit]
 165                    -> CLabel
 166                    -> CmmFormals
 167                    -> ListGraph CmmStmt
 168                    -> [RawCmmTop]
 169 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
 170   | 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   =             -- Use a zero place-holder in place of the
 176                 -- entry-label in the info table
 177     [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
 178
 179   | otherwise   -- Separately emit info table (with the function entry
 180   =             -- point as first entry) and the entry code
 181     [CmmProc [] entry_lbl args blocks,
 182      mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
 183
 184 mkSRTLit :: CLabel
 185          -> C_SRT
 186          -> ([CmmLit],    -- srt_label
 187              StgHalfWord) -- srt_bitmap
 188 mkSRTLit _          NoC_SRT = ([], 0)
 189 mkSRTLit info_label (C_SRT lbl off bitmap) =
 190     ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
 191
 192 -------------------------------------------------------------------------
 193 --
 194 --              Build a liveness mask for the stack layout
 195 --
 196 -------------------------------------------------------------------------
 197
 198 -- There are four kinds of things on the stack:
 199 --
 200 --      - pointer variables (bound in the environment)
 201 --      - non-pointer variables (bound in the environment)
 202 --      - free slots (recorded in the stack free list)
 203 --      - non-pointer data slots (recorded in the stack free list)
 204 --
 205 -- The first two are represented with a 'Just' of a 'LocalReg'.
 206 -- The last two with one or more 'Nothing' constructors.
 207 -- Each 'Nothing' represents one used word.
 208 --
 209 -- The head of the stack layout is the top of the stack and
 210 -- the least-significant bit.
 211
 212 -- TODO: refactor to use utility functions
 213 -- TODO: combine with CgCallConv.mkLiveness (see comment there)
 214 mkLiveness :: Unique
 215            -> [Maybe LocalReg]
 216            -> (CmmLit, [RawCmmTop], ClosureTypeTag)
 217               -- ^ Returns:
 218               --   1. The bitmap (literal value or label)
 219               --   2. Large bitmap CmmData if needed
 220               --   3. rET_SMALL or rET_BIG
 221 mkLiveness uniq live =
 222   if length bits > mAX_SMALL_BITMAP_SIZE
 223     -- does not fit in one word
 224     then (CmmLabel big_liveness, [data_lits], rET_BIG)
 225     -- fits in one word
 226     else (mkWordCLit  small_liveness, [], rET_SMALL)
 227   where
 228     mkBits [] = []
 229     mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
 230         sizeW = case reg of
 231                   Nothing -> 1
 232                   Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1)
 233                             `quot` wORD_SIZE
 234                             -- number of words, rounded up
 235         bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
 236
 237     is_non_ptr Nothing    = True
 238     is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
 239
 240     bits :: [Bool]
 241     bits = mkBits live
 242
 243     bitmap :: Bitmap
 244     bitmap = mkBitmap bits
 245
 246     small_bitmap = case bitmap of
 247                    []  -> 0
 248                    [b] -> fromIntegral b
 249                    _   -> panic "mkLiveness"
 250     small_liveness =
 251         fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
 252
 253     big_liveness = mkBitmapLabel uniq
 254     lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
 255     data_lits = mkRODataLits big_liveness lits
 256
 257 -------------------------------------------------------------------------
 258 --
 259 --      Generating a standard info table
 260 --
 261 -------------------------------------------------------------------------
 262
 263 -- The standard bits of an info table.  This part of the info table
 264 -- corresponds to the StgInfoTable type defined in InfoTables.h.
 265 --
 266 -- Its shape varies with ticky/profiling/tables next to code etc
 267 -- so we can't use constant offsets from Constants
 268
 269 mkStdInfoTable
 270    :: CmmLit            -- closure type descr (profiling)
 271    -> CmmLit            -- closure descr (profiling)
 272    -> StgHalfWord       -- closure type
 273    -> StgHalfWord       -- SRT length
 274    -> CmmLit            -- layout field
 275    -> [CmmLit]
 276
 277 mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
 278  =      -- Parallel revertible-black hole field
 279     prof_info
 280         -- Ticky info (none at present)
 281         -- Debug info (none at present)
 282  ++ [layout_lit, type_lit]
 283
 284  where
 285     prof_info
 286         | opt_SccProfilingOn = [type_descr, closure_descr]
 287         | otherwise          = []
 288
 289     type_lit = packHalfWordsCLit cl_type srt_len
 290