Snapshot of codegen refactoring to share with simonpj
[ghc.git] / compiler / codeGen / CgInfoTbls.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Building info tables.
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgInfoTbls (
10 emitClosureCodeAndInfoTable,
11 emitInfoTableAndCode,
12 emitReturnTarget, emitAlgReturnTarget,
13 emitReturnInstr,
14 stdInfoTableSizeB,
15 entryCode, closureInfoPtr,
16 getConstrTag,
17 cmmGetClosureType,
18 infoTable, infoTableClosureType,
19 infoTablePtrs, infoTableNonPtrs,
20 funInfoTable, makeRelativeRefTo
21 ) where
22
23
24 #include "HsVersions.h"
25
26 import ClosureInfo
27 import SMRep
28 import CgBindery
29 import CgCallConv
30 import CgUtils
31 import CgMonad
32 import CmmBuildInfoTables
33
34 import OldCmm
35 import CLabel
36 import Name
37 import Unique
38 import StaticFlags
39
40 import Constants
41 import Util
42 import Outputable
43
44 -------------------------------------------------------------------------
45 --
46 -- Generating the info table and code for a closure
47 --
48 -------------------------------------------------------------------------
49
50 -- Here we make an info table of type 'CmmInfo'. The concrete
51 -- representation as a list of 'CmmAddr' is handled later
52 -- in the pipeline by 'cmmToRawCmm'.
53
54 emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code
55 emitClosureCodeAndInfoTable cl_info args body
56 = do { blks <- cgStmtsToBlocks body
57 ; info <- mkCmmInfo cl_info
58 ; emitInfoTableAndCode (entryLabelFromCI cl_info) info args blks }
59
60 -- Convert from 'ClosureInfo' to 'CmmInfo'.
61 -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
62 mkCmmInfo :: ClosureInfo -> FCode CmmInfo
63 mkCmmInfo cl_info
64 = return (CmmInfo gc_target Nothing $
65 CmmInfoTable { cit_lbl = infoTableLabelFromCI cl_info,
66 cit_rep = closureSMRep cl_info,
67 cit_prof = prof,
68 cit_srt = closureSRT cl_info })
69 where
70 prof | not opt_SccProfilingOn = NoProfilingInfo
71 | otherwise = ProfilingInfo ty_descr_w8 val_descr_w8
72 ty_descr_w8 = stringToWord8s (closureTypeDescr cl_info)
73 val_descr_w8 = stringToWord8s (closureValDescr cl_info)
74
75 -- The gc_target is to inform the CPS pass when it inserts a stack check.
76 -- Since that pass isn't used yet we'll punt for now.
77 -- When the CPS pass is fully integrated, this should
78 -- be replaced by the label that any heap check jumped to,
79 -- so that branch can be shared by both the heap (from codeGen)
80 -- and stack checks (from the CPS pass).
81 gc_target = panic "TODO: gc_target"
82
83 -------------------------------------------------------------------------
84 --
85 -- Generating the info table and code for a return point
86 --
87 -------------------------------------------------------------------------
88
89 -- The concrete representation as a list of 'CmmAddr' is handled later
90 -- in the pipeline by 'cmmToRawCmm'.
91
92 emitReturnTarget
93 :: Name
94 -> CgStmts -- The direct-return code (if any)
95 -> FCode CLabel
96 emitReturnTarget name stmts
97 = do { srt_info <- getSRTInfo
98 ; blks <- cgStmtsToBlocks stmts
99 ; frame <- mkStackLayout
100 ; let smrep = mkStackRep (mkLiveness frame)
101 info = CmmInfo gc_target Nothing info_tbl
102 info_tbl = CmmInfoTable { cit_lbl = info_lbl
103 , cit_prof = NoProfilingInfo
104 , cit_rep = smrep
105 , cit_srt = srt_info }
106 ; emitInfoTableAndCode entry_lbl info args blks
107 ; return info_lbl }
108 where
109 args = {- trace "emitReturnTarget: missing args" -} []
110 uniq = getUnique name
111 info_lbl = mkReturnInfoLabel uniq
112 entry_lbl = mkReturnPtLabel uniq
113
114 -- The gc_target is to inform the CPS pass when it inserts a stack check.
115 -- Since that pass isn't used yet we'll punt for now.
116 -- When the CPS pass is fully integrated, this should
117 -- be replaced by the label that any heap check jumped to,
118 -- so that branch can be shared by both the heap (from codeGen)
119 -- and stack checks (from the CPS pass).
120 gc_target = panic "TODO: gc_target"
121
122 -- Build stack layout information from the state of the 'FCode' monad.
123 -- Should go away once 'codeGen' starts using the CPS conversion
124 -- pass to handle the stack. Until then, this is really just
125 -- here to convert from the 'codeGen' representation of the stack
126 -- to the 'CmmInfo' representation of the stack.
127 --
128 -- See 'CmmInfo.mkLiveness' for where this is converted to a bitmap.
129
130 {-
131 This seems to be a very error prone part of the code.
132 It is surprisingly prone to off-by-one errors, because
133 it converts between offset form (codeGen) and list form (CmmInfo).
134 Thus a bit of explanation is in order.
135 Fortunately, this code should go away once the code generator
136 starts using the CPS conversion pass to handle the stack.
137
138 The stack looks like this:
139
140 | |
141 |-------------|
142 frame_sp --> | return addr |
143 |-------------|
144 | dead slot |
145 |-------------|
146 | live ptr b |
147 |-------------|
148 | live ptr a |
149 |-------------|
150 real_sp --> | return addr |
151 +-------------+
152
153 Both 'frame_sp' and 'real_sp' are measured downwards
154 (i.e. larger frame_sp means smaller memory address).
155
156 For that frame we want a result like: [Just a, Just b, Nothing]
157 Note that the 'head' of the list is the top
158 of the stack, and that the return address
159 is not present in the list (it is always assumed).
160 -}
161 mkStackLayout :: FCode [Maybe LocalReg]
162 mkStackLayout = do
163 StackUsage { realSp = real_sp,
164 frameSp = frame_sp } <- getStkUsage
165 binds <- getLiveStackBindings
166 let frame_size = real_sp - frame_sp - retAddrSizeW
167 rel_binds = reverse $ sortWith fst
168 [(offset - frame_sp - retAddrSizeW, b)
169 | (offset, b) <- binds]
170
171 WARN( not (all (\bind -> fst bind >= 0) rel_binds),
172 ppr binds $$ ppr rel_binds $$
173 ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
174 return $ stack_layout rel_binds frame_size
175
176 stack_layout :: [(VirtualSpOffset, CgIdInfo)]
177 -> WordOff
178 -> [Maybe LocalReg]
179 stack_layout [] sizeW = replicate sizeW Nothing
180 stack_layout ((off, bind):binds) sizeW | off == sizeW - 1 =
181 (Just stack_bind) : (stack_layout binds (sizeW - rep_size))
182 where
183 rep_size = cgRepSizeW (cgIdInfoArgRep bind)
184 stack_bind = LocalReg unique machRep
185 unique = getUnique (cgIdInfoId bind)
186 machRep = argMachRep (cgIdInfoArgRep bind)
187 stack_layout binds@(_:_) sizeW | otherwise =
188 Nothing : (stack_layout binds (sizeW - 1))
189
190 {- Another way to write the function that might be less error prone (untested)
191 stack_layout offsets sizeW = result
192 where
193 y = map (flip lookup offsets) [0..]
194 -- offsets -> nothing and just (each slot is one word)
195 x = take sizeW y -- set the frame size
196 z = clip x -- account for multi-word slots
197 result = map mk_reg z
198
199 clip [] = []
200 clip list@(x : _) = x : clip (drop count list)
201 ASSERT(all isNothing (tail (take count list)))
202
203 count Nothing = 1
204 count (Just x) = cgRepSizeW (cgIdInfoArgRep x)
205
206 mk_reg Nothing = Nothing
207 mk_reg (Just x) = LocalReg unique machRep kind
208 where
209 unique = getUnique (cgIdInfoId x)
210 machRep = argMachrep (cgIdInfoArgRep bind)
211 kind = if isFollowableArg (cgIdInfoArgRep bind)
212 then GCKindPtr
213 else GCKindNonPtr
214 -}
215
216 emitAlgReturnTarget
217 :: Name -- Just for its unique
218 -> [(ConTagZ, CgStmts)] -- Tagged branches
219 -> Maybe CgStmts -- Default branch (if any)
220 -> Int -- family size
221 -> FCode (CLabel, SemiTaggingStuff)
222
223 emitAlgReturnTarget name branches mb_deflt fam_sz
224 = do { blks <- getCgStmts $
225 -- is the constructor tag in the node reg?
226 if isSmallFamily fam_sz
227 then do -- yes, node has constr. tag
228 let tag_expr = cmmConstrTag1 (CmmReg nodeReg)
229 branches' = [(tag+1,branch)|(tag,branch)<-branches]
230 emitSwitch tag_expr branches' mb_deflt 1 fam_sz
231 else do -- no, get tag from info table
232 let -- Note that ptr _always_ has tag 1
233 -- when the family size is big enough
234 untagged_ptr = cmmRegOffB nodeReg (-1)
235 tag_expr = getConstrTag (untagged_ptr)
236 emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
237 ; lbl <- emitReturnTarget name blks
238 ; return (lbl, Nothing) }
239 -- Nothing: the internal branches in the switch don't have
240 -- global labels, so we can't use them at the 'call site'
241
242 --------------------------------
243 emitReturnInstr :: Code
244 emitReturnInstr
245 = do { info_amode <- getSequelAmode
246 ; stmtC (CmmJump (entryCode info_amode) []) }
247
248 -----------------------------------------------------------------------------
249 --
250 -- Info table offsets
251 --
252 -----------------------------------------------------------------------------
253
254 stdInfoTableSizeW :: WordOff
255 -- The size of a standard info table varies with profiling/ticky etc,
256 -- so we can't get it from Constants
257 -- It must vary in sync with mkStdInfoTable
258 stdInfoTableSizeW
259 = size_fixed + size_prof
260 where
261 size_fixed = 2 -- layout, type
262 size_prof | opt_SccProfilingOn = 2
263 | otherwise = 0
264
265 stdInfoTableSizeB :: ByteOff
266 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
267
268 stdSrtBitmapOffset :: ByteOff
269 -- Byte offset of the SRT bitmap half-word which is
270 -- in the *higher-addressed* part of the type_lit
271 stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE
272
273 stdClosureTypeOffset :: ByteOff
274 -- Byte offset of the closure type half-word
275 stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE
276
277 stdPtrsOffset, stdNonPtrsOffset :: ByteOff
278 stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE
279 stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE
280
281 -------------------------------------------------------------------------
282 --
283 -- Accessing fields of an info table
284 --
285 -------------------------------------------------------------------------
286
287 closureInfoPtr :: CmmExpr -> CmmExpr
288 -- Takes a closure pointer and returns the info table pointer
289 closureInfoPtr e = CmmLoad e bWord
290
291 entryCode :: CmmExpr -> CmmExpr
292 -- Takes an info pointer (the first word of a closure)
293 -- and returns its entry code
294 entryCode e | tablesNextToCode = e
295 | otherwise = CmmLoad e bWord
296
297 getConstrTag :: CmmExpr -> CmmExpr
298 -- Takes a closure pointer, and return the *zero-indexed*
299 -- constructor tag obtained from the info table
300 -- This lives in the SRT field of the info table
301 -- (constructors don't need SRTs).
302 getConstrTag closure_ptr
303 = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
304 where
305 info_table = infoTable (closureInfoPtr closure_ptr)
306
307 cmmGetClosureType :: CmmExpr -> CmmExpr
308 -- Takes a closure pointer, and return the closure type
309 -- obtained from the info table
310 cmmGetClosureType closure_ptr
311 = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
312 where
313 info_table = infoTable (closureInfoPtr closure_ptr)
314
315 infoTable :: CmmExpr -> CmmExpr
316 -- Takes an info pointer (the first word of a closure)
317 -- and returns a pointer to the first word of the standard-form
318 -- info table, excluding the entry-code word (if present)
319 infoTable info_ptr
320 | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB)
321 | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer
322
323 infoTableConstrTag :: CmmExpr -> CmmExpr
324 -- Takes an info table pointer (from infoTable) and returns the constr tag
325 -- field of the info table (same as the srt_bitmap field)
326 infoTableConstrTag = infoTableSrtBitmap
327
328 infoTableSrtBitmap :: CmmExpr -> CmmExpr
329 -- Takes an info table pointer (from infoTable) and returns the srt_bitmap
330 -- field of the info table
331 infoTableSrtBitmap info_tbl
332 = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
333
334 infoTableClosureType :: CmmExpr -> CmmExpr
335 -- Takes an info table pointer (from infoTable) and returns the closure type
336 -- field of the info table.
337 infoTableClosureType info_tbl
338 = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
339
340 infoTablePtrs :: CmmExpr -> CmmExpr
341 infoTablePtrs info_tbl
342 = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
343
344 infoTableNonPtrs :: CmmExpr -> CmmExpr
345 infoTableNonPtrs info_tbl
346 = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
347
348 funInfoTable :: CmmExpr -> CmmExpr
349 -- Takes the info pointer of a function,
350 -- and returns a pointer to the first word of the StgFunInfoExtra struct
351 -- in the info table.
352 funInfoTable info_ptr
353 | tablesNextToCode
354 = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
355 | otherwise
356 = cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
357 -- Past the entry code pointer
358
359 -------------------------------------------------------------------------
360 --
361 -- Emit the code for a closure (or return address)
362 -- and its associated info table
363 --
364 -------------------------------------------------------------------------
365
366 -- The complication here concerns whether or not we can
367 -- put the info table next to the code
368
369 emitInfoTableAndCode
370 :: CLabel -- Label of entry or ret
371 -> CmmInfo -- ...the info table
372 -> [CmmFormal] -- ...args
373 -> [CmmBasicBlock] -- ...and body
374 -> Code
375
376 emitInfoTableAndCode entry_ret_lbl info args blocks
377 = emitProc info entry_ret_lbl args blocks
378
379 -------------------------------------------------------------------------
380 --
381 -- Position independent code
382 --
383 -------------------------------------------------------------------------
384 -- In order to support position independent code, we mustn't put absolute
385 -- references into read-only space. Info tables in the tablesNextToCode
386 -- case must be in .text, which is read-only, so we doctor the CmmLits
387 -- to use relative offsets instead.
388
389 -- Note that this is done even when the -fPIC flag is not specified,
390 -- as we want to keep binary compatibility between PIC and non-PIC.
391
392 makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit
393
394 makeRelativeRefTo info_lbl (CmmLabel lbl)
395 | tablesNextToCode
396 = CmmLabelDiffOff lbl info_lbl 0
397 makeRelativeRefTo info_lbl (CmmLabelOff lbl off)
398 | tablesNextToCode
399 = CmmLabelDiffOff lbl info_lbl off
400 makeRelativeRefTo _ lit = lit