compiler/cmm/CmmInfo.hs

   1 module CmmInfo (
   2   mkInfoTable
   3 ) where
   4
   5 #include "HsVersions.h"
   6
   7 import Cmm
   8 import CmmUtils
   9
  10 import CLabel
  11
  12 import Bitmap
  13 import ClosureInfo
  14 import CgInfoTbls
  15 import CgCallConv
  16 import CgUtils
  17
  18 import Constants
  19 import StaticFlags
  20 import Unique
  21 import Panic
  22
  23 import Data.Bits
  24
  25 mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
  26 mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
  27 mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
  28     case info of
  29       CmmNonInfo -> [CmmProc [] entry_label arguments blocks]
  30       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
  31               (FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
  32           mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
  33           where
  34             fun_extra_bits =
  35                [packHalfWordsCLit fun_type fun_arity] ++
  36                srt_label ++
  37                case pap_bitmap of
  38                  ArgGen liveness ->
  39                      [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
  40                       makeRelativeRefTo info_label (CmmLabel slow_entry)]
  41                  _ -> []
  42             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
  43             info_label = entryLblToInfoLbl entry_label
  44             (srt_label, srt_bitmap) =
  45                 case srt of
  46                   NoC_SRT -> ([], 0)
  47                   (C_SRT lbl off bitmap) ->
  48                       ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
  49                        bitmap)
  50             layout = packHalfWordsCLit ptrs nptrs
  51
  52       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
  53               (ConstrInfo (ptrs, nptrs) con_tag descr) ->
  54           mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks
  55           where
  56             std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
  57             info_label = entryLblToInfoLbl entry_label
  58             con_name = makeRelativeRefTo info_label (CmmLabel descr)
  59             layout = packHalfWordsCLit ptrs nptrs
  60
  61       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
  62               (ThunkInfo (ptrs, nptrs) srt) ->
  63           mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
  64           where
  65             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
  66             info_label = entryLblToInfoLbl entry_label
  67             (srt_label, srt_bitmap) =
  68                 case srt of
  69                   NoC_SRT -> ([], 0)
  70                   (C_SRT lbl off bitmap) ->
  71                       ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
  72                        bitmap)
  73             layout = packHalfWordsCLit ptrs nptrs
  74
  75       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
  76           liveness_data ++
  77           mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
  78           where
  79             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
  80             info_label = entryLblToInfoLbl entry_label
  81             (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
  82             (srt_label, srt_bitmap) =
  83                 case srt of
  84                   NoC_SRT -> ([], 0)
  85                   (C_SRT lbl off bitmap) ->
  86                       ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
  87                        bitmap)
  88
  89 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
  90   | tablesNextToCode    -- Reverse the extra_bits; and emit the top-level proc
  91   = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]
  92
  93   | null blocks -- No actual code; only the info table is significant
  94   =             -- Use a zero place-holder in place of the
  95                 -- entry-label in the info table
  96     [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
  97
  98   | otherwise   -- Separately emit info table (with the function entry
  99   =             -- point as first entry) and the entry code
 100     [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
 101      CmmProc [] entry_lbl args blocks]
 102
 103 -- TODO: refactor to use utility functions
 104 mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
 105 mkLiveness uniq live
 106   = if length live > mAX_SMALL_BITMAP_SIZE
 107     then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
 108     else (mkWordCLit small_liveness, []) -- fits in one word
 109   where
 110     size = length live
 111
 112     bits = mkBitmap (map is_non_ptr live)
 113     is_non_ptr Nothing = True
 114     is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
 115     is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False
 116
 117     big_liveness = mkBitmapLabel uniq
 118     data_lits = mkRODataLits big_liveness lits
 119     lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
 120
 121     small_liveness =
 122         fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
 123     small_bits = case bits of
 124                    []  -> 0
 125                    [b] -> fromIntegral b
 126                    _   -> panic "mkLiveness"