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
29
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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
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
|
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
CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
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
con_name = makeRelativeRefTo info_label descr
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
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)
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"
|
