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