compiler/cmm/CmmInfo.hs

   1 {-# OPTIONS_GHC -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/WorkingConventions#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 import PprCmm
  18
  19 import CLabel
  20 import MachOp
  21
  22 import Bitmap
  23 import ClosureInfo
  24 import CgInfoTbls
  25 import CgCallConv
  26 import CgUtils
  27 import SMRep
  28
  29 import Constants
  30 import StaticFlags
  31 import DynFlags
  32 import Unique
  33 import UniqSupply
  34 import Panic
  35
  36 import Data.Bits
  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 uniq (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_type fun_arity pap_bitmap slow_entry ->
  93               mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
  94                                  arguments blocks
  95             where
  96               fun_extra_bits =
  97                  [packHalfWordsCLit fun_type fun_arity] ++
  98                  case pap_bitmap of
  99                  ArgGen liveness ->
 100                      (if null srt_label then [mkIntCLit 0] else srt_label) ++
 101                      [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
 102                       makeRelativeRefTo info_label slow_entry]
 103                  _ -> srt_label
 104               std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap
 105                                         layout
 106               (srt_label, srt_bitmap) = mkSRTLit info_label srt
 107               layout = packHalfWordsCLit ptrs nptrs
 108
 109           -- | A constructor.
 110           ConstrInfo (ptrs, nptrs) con_tag descr ->
 111               mkInfoTableAndCode info_label std_info [con_name] entry_label
 112                                  arguments blocks
 113               where
 114                 std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
 115                 con_name = makeRelativeRefTo info_label descr
 116                 layout = packHalfWordsCLit ptrs nptrs
 117
 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 -- Handle the differences between tables-next-to-code
 150 -- and not tables-next-to-code
 151 mkInfoTableAndCode :: CLabel
 152                    -> [CmmLit]
 153                    -> [CmmLit]
 154                    -> CLabel
 155                    -> CmmFormals
 156                    -> [CmmBasicBlock]
 157                    -> [RawCmmTop]
 158 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
 159   | tablesNextToCode    -- Reverse the extra_bits; and emit the top-level proc
 160   = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
 161              entry_lbl args blocks]
 162
 163   | null blocks -- No actual code; only the info table is significant
 164   =             -- Use a zero place-holder in place of the
 165                 -- entry-label in the info table
 166     [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
 167
 168   | otherwise   -- Separately emit info table (with the function entry
 169   =             -- point as first entry) and the entry code
 170     [CmmProc [] entry_lbl args blocks,
 171      mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
 172
 173 mkSRTLit :: CLabel
 174          -> C_SRT
 175          -> ([CmmLit],    -- srt_label
 176              StgHalfWord) -- srt_bitmap
 177 mkSRTLit info_label NoC_SRT = ([], 0)
 178 mkSRTLit info_label (C_SRT lbl off bitmap) =
 179     ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
 180
 181 -------------------------------------------------------------------------
 182 --
 183 --              Build a liveness mask for the stack layout
 184 --
 185 -------------------------------------------------------------------------
 186
 187 -- There are four kinds of things on the stack:
 188 --
 189 --      - pointer variables (bound in the environment)
 190 --      - non-pointer variables (bound in the environment)
 191 --      - free slots (recorded in the stack free list)
 192 --      - non-pointer data slots (recorded in the stack free list)
 193 --
 194 -- The first two are represented with a 'Just' of a 'LocalReg'.
 195 -- The last two with one or more 'Nothing' constructors.
 196 -- Each 'Nothing' represents one used word.
 197 --
 198 -- The head of the stack layout is the top of the stack and
 199 -- the least-significant bit.
 200
 201 -- TODO: refactor to use utility functions
 202 -- TODO: combine with CgCallConv.mkLiveness (see comment there)
 203 mkLiveness :: Unique
 204            -> [Maybe LocalReg]
 205            -> (CmmLit,           -- ^ The bitmap (literal value or label)
 206                [RawCmmTop],      -- ^ Large bitmap CmmData if needed
 207                ClosureTypeTag)   -- ^ rET_SMALL or rET_BIG
 208 mkLiveness uniq live =
 209   if length bits > mAX_SMALL_BITMAP_SIZE
 210     -- does not fit in one word
 211     then (CmmLabel big_liveness, [data_lits], rET_BIG)
 212     -- fits in one word
 213     else (mkWordCLit small_liveness, [], rET_SMALL)
 214   where
 215     mkBits [] = []
 216     mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
 217         sizeW = case reg of
 218                   Nothing -> 1
 219                   Just r -> (machRepByteWidth (localRegRep r) + wORD_SIZE - 1)
 220                             `quot` wORD_SIZE
 221                             -- number of words, rounded up
 222         bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
 223
 224     is_non_ptr Nothing = True
 225     is_non_ptr (Just reg) =
 226         case localRegGCFollow reg of
 227           KindNonPtr -> True
 228           KindPtr -> False
 229
 230     bits :: [Bool]
 231     bits = mkBits live
 232
 233     bitmap :: Bitmap
 234     bitmap = mkBitmap bits
 235
 236     small_bitmap = case bitmap of
 237                    []  -> 0
 238                    [b] -> fromIntegral b
 239                    _   -> panic "mkLiveness"
 240     small_liveness =
 241         fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
 242
 243     big_liveness = mkBitmapLabel uniq
 244     lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
 245     data_lits = mkRODataLits big_liveness lits
 246
 247 -------------------------------------------------------------------------
 248 --
 249 --      Generating a standard info table
 250 --
 251 -------------------------------------------------------------------------
 252
 253 -- The standard bits of an info table.  This part of the info table
 254 -- corresponds to the StgInfoTable type defined in InfoTables.h.
 255 --
 256 -- Its shape varies with ticky/profiling/tables next to code etc
 257 -- so we can't use constant offsets from Constants
 258
 259 mkStdInfoTable
 260    :: CmmLit            -- closure type descr (profiling)
 261    -> CmmLit            -- closure descr (profiling)
 262    -> StgHalfWord       -- closure type
 263    -> StgHalfWord       -- SRT length
 264    -> CmmLit            -- layout field
 265    -> [CmmLit]
 266
 267 mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
 268  =      -- Parallel revertible-black hole field
 269     prof_info
 270         -- Ticky info (none at present)
 271         -- Debug info (none at present)
 272  ++ [layout_lit, type_lit]
 273
 274  where
 275     prof_info
 276         | opt_SccProfilingOn = [type_descr, closure_descr]
 277         | otherwise          = []
 278
 279     type_lit = packHalfWordsCLit cl_type srt_len