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 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
  76               (ThunkSelectorInfo offset srt) ->
  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 (mkWordCLit offset)
  80             info_label = entryLblToInfoLbl entry_label
  81             (srt_label, srt_bitmap) =
  82                 case srt of
  83                   NoC_SRT -> ([], 0)
  84                   (C_SRT lbl off bitmap) ->
  85                       ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
  86                        bitmap)
  87
  88       CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
  89           liveness_data ++
  90           mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
  91           where
  92             std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
  93             info_label = entryLblToInfoLbl entry_label
  94             (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
  95             (srt_label, srt_bitmap) =
  96                 case srt of
  97                   NoC_SRT -> ([], 0)
  98                   (C_SRT lbl off bitmap) ->
  99                       ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
 100                        bitmap)
 101
 102 mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
 103   | tablesNextToCode    -- Reverse the extra_bits; and emit the top-level proc
 104   = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]
 105
 106   | null blocks -- No actual code; only the info table is significant
 107   =             -- Use a zero place-holder in place of the
 108                 -- entry-label in the info table
 109     [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
 110
 111   | otherwise   -- Separately emit info table (with the function entry
 112   =             -- point as first entry) and the entry code
 113     [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
 114      CmmProc [] entry_lbl args blocks]
 115
 116 -- TODO: refactor to use utility functions
 117 mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
 118 mkLiveness uniq live
 119   = if length live > mAX_SMALL_BITMAP_SIZE
 120     then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
 121     else (mkWordCLit small_liveness, []) -- fits in one word
 122   where
 123     size = length live
 124
 125     bits = mkBitmap (map is_non_ptr live)
 126     is_non_ptr Nothing = True
 127     is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
 128     is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False
 129
 130     big_liveness = mkBitmapLabel uniq
 131     data_lits = mkRODataLits big_liveness lits
 132     lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
 133
 134     small_liveness =
 135         fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
 136     small_bits = case bits of
 137                    []  -> 0
 138                    [b] -> fromIntegral b
 139                    _   -> panic "mkLiveness"