compiler/cmm/CmmInfo.hs

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