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