CmmInfo.hs 5.48 KB
Newer Older
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
module CmmInfo (
  mkInfoTable
) where

#include "HsVersions.h"

import Cmm
import CmmUtils

import CLabel

import Bitmap
import ClosureInfo
import CgInfoTbls
import CgCallConv
import CgUtils

import Constants
import StaticFlags
import Unique
import Panic

import Data.Bits

mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
    case info of
29
      CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
              (FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
          mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
          where
            fun_extra_bits =
               [packHalfWordsCLit fun_type fun_arity] ++
               srt_label ++
               case pap_bitmap of
                 ArgGen liveness ->
                     [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
                      makeRelativeRefTo info_label (CmmLabel slow_entry)]
                 _ -> []
            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
            info_label = entryLblToInfoLbl entry_label
            (srt_label, srt_bitmap) =
                case srt of
                  NoC_SRT -> ([], 0)
                  (C_SRT lbl off bitmap) ->
                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
                       bitmap)
            layout = packHalfWordsCLit ptrs nptrs

      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
              (ConstrInfo (ptrs, nptrs) con_tag descr) ->
          mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks
          where
            std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
            info_label = entryLblToInfoLbl entry_label
58
            con_name = makeRelativeRefTo info_label descr
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
            layout = packHalfWordsCLit ptrs nptrs

      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
              (ThunkInfo (ptrs, nptrs) srt) ->
          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
          where
            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
            info_label = entryLblToInfoLbl entry_label
            (srt_label, srt_bitmap) =
                case srt of
                  NoC_SRT -> ([], 0)
                  (C_SRT lbl off bitmap) ->
                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
                       bitmap)
            layout = packHalfWordsCLit ptrs nptrs

75
76
77
78
79
80
81
82
83
84
85
86
87
      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
              (ThunkSelectorInfo offset srt) ->
          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
          where
            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset)
            info_label = entryLblToInfoLbl entry_label
            (srt_label, srt_bitmap) =
                case srt of
                  NoC_SRT -> ([], 0)
                  (C_SRT lbl off bitmap) ->
                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
                       bitmap)

88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
      CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
          liveness_data ++
          mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
          where
            std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
            info_label = entryLblToInfoLbl entry_label
            (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
            (srt_label, srt_bitmap) =
                case srt of
                  NoC_SRT -> ([], 0)
                  (C_SRT lbl off bitmap) ->
                      ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
                       bitmap)

mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
  = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]

  | null blocks -- No actual code; only the info table is significant
  =		-- Use a zero place-holder in place of the 
		-- entry-label in the info table
    [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]

  | otherwise	-- Separately emit info table (with the function entry 
  =		-- point as first entry) and the entry code 
    [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
     CmmProc [] entry_lbl args blocks]

-- TODO: refactor to use utility functions
mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
mkLiveness uniq live
  = if length live > mAX_SMALL_BITMAP_SIZE
    then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
    else (mkWordCLit small_liveness, []) -- fits in one word
  where
    size = length live

    bits = mkBitmap (map is_non_ptr live)
    is_non_ptr Nothing = True
    is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
    is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False

    big_liveness = mkBitmapLabel uniq
    data_lits = mkRODataLits big_liveness lits
    lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
  
    small_liveness =
        fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
    small_bits = case bits of 
		   []  -> 0
		   [b] -> fromIntegral b
		   _   -> panic "mkLiveness"