CmmInfo.hs 9.6 KB
Newer Older
1
module CmmInfo (
2
  emptyContInfoTable,
3
  cmmToRawCmm,
4
  mkInfoTable,
5
6
7
8
) where

#include "HsVersions.h"

9
import OldCmm
10
11
12
13
14
15
16
17
18
import CmmUtils

import CLabel

import Bitmap
import ClosureInfo
import CgInfoTbls
import CgCallConv
import CgUtils
19
import SMRep
20
21

import Constants
22
import Panic
23
24
import StaticFlags
import Unique
25
import UniqSupply
26
27
28

import Data.Bits

29
-- When we split at proc points, we need an empty info table.
30
31
32
emptyContInfoTable :: CmmInfoTable
emptyContInfoTable = CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
                                  (ContInfo [] NoC_SRT)
33
34
    where zero = CmmInt 0 wordWidth

35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
cmmToRawCmm :: [Cmm] -> IO [RawCmm]
cmmToRawCmm cmm = do
  info_tbl_uniques <- mkSplitUniqSupply 'i'
  return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
    where
      raw_cmm uniq_supply (Cmm procs) =
          Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs

-- Make a concrete info table, represented as a list of CmmStatic
-- (it can't be simply a list of Word, because the SRT field is
-- represented by a label+offset expression).
--
-- With tablesNextToCode, the layout is
--	<reversed variable part>
--	<normal forward StgInfoTable, but without 
--		an entry point at the front>
--	<code>
--
-- Without tablesNextToCode, the layout of an info table is
--	<entry label>
--	<normal forward rest of StgInfoTable>
--	<forward variable part>
--
Simon Marlow's avatar
Simon Marlow committed
58
--	See includes/rts/storage/InfoTables.h
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
--
-- For return-points these are as follows
--
-- Tables next to code:
--
--			<srt slot>
--			<standard info table>
--  	ret-addr -->	<entry code (if any)>
--
-- Not tables-next-to-code:
--
--	ret-addr -->	<ptr to entry code>
--			<standard info table>
--			<srt slot>
--
--  * The SRT slot is only there if there is SRT info to record

76
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
Ian Lynagh's avatar
Ian Lynagh committed
77
mkInfoTable _    (CmmData sec dat) = [CmmData sec dat]
78
mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) =
79
    case info of
Thomas Schilling's avatar
Thomas Schilling committed
80
      -- Code without an info table.  Easy.
81
      CmmNonInfoTable -> [CmmProc Nothing entry_label blocks]
82

83
      CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
84
          let info_label = entryLblToInfoLbl entry_label
85
86
              ty_prof'   = makeRelativeRefTo info_label ty_prof
              cl_prof'   = makeRelativeRefTo info_label cl_prof
87
          in case type_info of
Thomas Schilling's avatar
Thomas Schilling committed
88
          -- A function entry point.
89
          FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry ->
90
              mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
91
                                 blocks
92
            where
93
              fun_type = argDescrType pap_bitmap
94
95
96
              fun_extra_bits =
                 [packHalfWordsCLit fun_type fun_arity] ++
                 case pap_bitmap of
97
                 ArgGen liveness ->
98
                     (if null srt_label then [mkIntCLit 0] else srt_label) ++
99
                     [makeRelativeRefTo info_label $ mkLivenessCLit liveness,
100
                      makeRelativeRefTo info_label slow_entry]
101
                 _ -> srt_label
102
103
104
105
              std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap
                                        layout
              (srt_label, srt_bitmap) = mkSRTLit info_label srt
              layout = packHalfWordsCLit ptrs nptrs
106

Thomas Schilling's avatar
Thomas Schilling committed
107
          -- A constructor.
108
109
          ConstrInfo (ptrs, nptrs) con_tag descr ->
              mkInfoTableAndCode info_label std_info [con_name] entry_label
110
                                 blocks
111
112
113
114
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
                con_name = makeRelativeRefTo info_label descr
                layout = packHalfWordsCLit ptrs nptrs
Thomas Schilling's avatar
Thomas Schilling committed
115
          -- A thunk.
116
117
          ThunkInfo (ptrs, nptrs) srt ->
              mkInfoTableAndCode info_label std_info srt_label entry_label
118
                                 blocks
119
120
121
122
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout
                (srt_label, srt_bitmap) = mkSRTLit info_label srt
                layout = packHalfWordsCLit ptrs nptrs
123

Thomas Schilling's avatar
Thomas Schilling committed
124
          -- A selector thunk.
Ian Lynagh's avatar
Ian Lynagh committed
125
          ThunkSelectorInfo offset _srt ->
126
              mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
127
                                 blocks
128
129
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
130

131
132
133
134
          -- A continuation/return-point.
          ContInfo stack_layout srt ->
              liveness_data ++
              mkInfoTableAndCode info_label std_info srt_label entry_label
135
                                 blocks
136
137
138
139
140
141
142
143
144
              where
                std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap
                                          (makeRelativeRefTo info_label liveness_lit)
                (liveness_lit, liveness_data, liveness_tag) =
                    mkLiveness uniq stack_layout
                maybe_big_type_tag = if type_tag == rET_SMALL
                                     then liveness_tag
                                     else type_tag
                (srt_label, srt_bitmap) = mkSRTLit info_label srt
145

146
147
148
149
150
151
-- Handle the differences between tables-next-to-code
-- and not tables-next-to-code
mkInfoTableAndCode :: CLabel
                   -> [CmmLit]
                   -> [CmmLit]
                   -> CLabel
152
                   -> ListGraph CmmStmt
153
                   -> [RawCmmTop]
154
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks
155
  | tablesNextToCode 	-- Reverse the extra_bits; and emit the top-level proc
156
  = [CmmProc (Just (Statics info_lbl $ map CmmStaticLit (reverse extra_bits ++ std_info)))
157
             entry_lbl blocks]
158

159
  | ListGraph [] <- blocks -- No code; only the info table is significant
160
161
162
163
164
165
  =		-- 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 
166
    [CmmProc Nothing entry_lbl blocks,
Ian Lynagh's avatar
Ian Lynagh committed
167
     mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
168

169
170
171
172
mkSRTLit :: CLabel
         -> C_SRT
         -> ([CmmLit],    -- srt_label
             StgHalfWord) -- srt_bitmap
Ian Lynagh's avatar
Ian Lynagh committed
173
mkSRTLit _          NoC_SRT = ([], 0)
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
mkSRTLit info_label (C_SRT lbl off bitmap) =
    ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)

-------------------------------------------------------------------------
--
--		Build a liveness mask for the stack layout
--
-------------------------------------------------------------------------

-- There are four kinds of things on the stack:
--
--	- pointer variables (bound in the environment)
-- 	- non-pointer variables (bound in the environment)
-- 	- free slots (recorded in the stack free list)
-- 	- non-pointer data slots (recorded in the stack free list)
--
-- The first two are represented with a 'Just' of a 'LocalReg'.
-- The last two with one or more 'Nothing' constructors.
-- Each 'Nothing' represents one used word.
--
-- The head of the stack layout is the top of the stack and
-- the least-significant bit.

197
-- TODO: refactor to use utility functions
198
199
200
-- TODO: combine with CgCallConv.mkLiveness (see comment there)
mkLiveness :: Unique
           -> [Maybe LocalReg]
Thomas Schilling's avatar
Thomas Schilling committed
201
202
203
204
205
           -> (CmmLit, [RawCmmTop], ClosureTypeTag)
              -- ^ Returns:
              --   1. The bitmap (literal value or label)
              --   2. Large bitmap CmmData if needed
              --   3. rET_SMALL or rET_BIG
206
207
208
209
210
mkLiveness uniq live =
  if length bits > mAX_SMALL_BITMAP_SIZE
    -- does not fit in one word
    then (CmmLabel big_liveness, [data_lits], rET_BIG)
    -- fits in one word
211
    else (mkWordCLit  small_liveness, [], rET_SMALL)
212
  where
213
214
215
216
    mkBits [] = []
    mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
        sizeW = case reg of
                  Nothing -> 1
217
                  Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1)
218
219
                            `quot` wORD_SIZE
                            -- number of words, rounded up
220
        bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
221

222
223
    is_non_ptr Nothing    = True
    is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg)
224

225
226
227
228
229
230
231
    bits :: [Bool]
    bits = mkBits live

    bitmap :: Bitmap
    bitmap = mkBitmap bits

    small_bitmap = case bitmap of 
232
		   []  -> 0
233
                   [b] -> b
234
		   _   -> panic "mkLiveness"
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
    small_liveness =
        fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)

    big_liveness = mkBitmapLabel uniq
    lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
    data_lits = mkRODataLits big_liveness lits

-------------------------------------------------------------------------
--
--	Generating a standard info table
--
-------------------------------------------------------------------------

-- The standard bits of an info table.  This part of the info table
-- corresponds to the StgInfoTable type defined in InfoTables.h.
--
-- Its shape varies with ticky/profiling/tables next to code etc
-- so we can't use constant offsets from Constants

mkStdInfoTable
   :: CmmLit		-- closure type descr (profiling)
   -> CmmLit		-- closure descr (profiling)
   -> StgHalfWord	-- closure type
   -> StgHalfWord	-- SRT length
   -> CmmLit		-- layout field
   -> [CmmLit]

mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
 = 	-- Parallel revertible-black hole field
    prof_info
	-- Ticky info (none at present)
	-- Debug info (none at present)
 ++ [layout_lit, type_lit]

 where  
    prof_info 
	| opt_SccProfilingOn = [type_descr, closure_descr]
	| otherwise	     = []

    type_lit = packHalfWordsCLit cl_type srt_len
275