ade0be1a94a3fc8fea740e8894b024be1c941000
[ghc.git] / compiler / codeGen / StgCmmBind.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation: bindings
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmBind (
10 cgTopRhsClosure,
11 cgBind,
12 emitBlackHoleCode,
13 pushUpdateFrame
14 ) where
15
16 #include "HsVersions.h"
17
18 import StgCmmExpr
19 import StgCmmMonad
20 import StgCmmEnv
21 import StgCmmCon
22 import StgCmmHeap
23 import StgCmmProf
24 import StgCmmTicky
25 import StgCmmGran
26 import StgCmmLayout
27 import StgCmmUtils
28 import StgCmmClosure
29 import StgCmmForeign (emitPrimCall)
30
31 import MkGraph
32 import CoreSyn ( AltCon(..) )
33 import SMRep
34 import Cmm
35 import CmmUtils
36 import CLabel
37 import StgSyn
38 import CostCentre
39 import Id
40 import Control.Monad
41 import Name
42 import Module
43 import ListSetOps
44 import Util
45 import BasicTypes
46 import Constants
47 import Outputable
48 import FastString
49 import Maybes
50
51 ------------------------------------------------------------------------
52 -- Top-level bindings
53 ------------------------------------------------------------------------
54
55 -- For closures bound at top level, allocate in static space.
56 -- They should have no free variables.
57
58 cgTopRhsClosure :: Id
59 -> CostCentreStack -- Optional cost centre annotation
60 -> StgBinderInfo
61 -> UpdateFlag
62 -> SRT
63 -> [Id] -- Args
64 -> StgExpr
65 -> FCode CgIdInfo
66
67 cgTopRhsClosure id ccs _ upd_flag srt args body = do
68 { -- LAY OUT THE OBJECT
69 let name = idName id
70 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
71 ; srt_info <- getSRTInfo srt
72 ; mod_name <- getModuleName
73 ; let descr = closureDescription mod_name name
74 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
75 closure_label = mkLocalClosureLabel name (idCafInfo id)
76 cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
77 caffy = idCafInfo id
78 info_tbl = mkCmmInfo closure_info -- XXX short-cut
79 closure_rep = mkStaticClosureFields info_tbl ccs caffy []
80
81 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
82 ; emitDataLits closure_label closure_rep
83 ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
84 (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
85 (addIdReps [])
86 -- Don't drop the non-void args until the closure info has been made
87 ; forkClosureBody (closureCodeBody True id closure_info ccs
88 (nonVoidIds args) (length args) body fv_details)
89
90 ; returnFC cg_id_info }
91
92 ------------------------------------------------------------------------
93 -- Non-top-level bindings
94 ------------------------------------------------------------------------
95
96 cgBind :: StgBinding -> FCode ()
97 cgBind (StgNonRec name rhs)
98 = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
99 ; addBindC (cg_id info) info
100 ; emit (init <*> body) }
101
102 cgBind (StgRec pairs)
103 = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
104 do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
105 ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
106 ; addBindsC new_binds
107 ; emit (catAGraphs inits <*> body) }
108
109 {- Recursive let-bindings are tricky.
110 Consider the following pseudocode:
111 let x = \_ -> ... y ...
112 y = \_ -> ... z ...
113 z = \_ -> ... x ...
114 in ...
115 For each binding, we need to allocate a closure, and each closure must
116 capture the address of the other closures.
117 We want to generate the following C-- code:
118 // Initialization Code
119 x = hp - 24; // heap address of x's closure
120 y = hp - 40; // heap address of x's closure
121 z = hp - 64; // heap address of x's closure
122 // allocate and initialize x
123 m[hp-8] = ...
124 m[hp-16] = y // the closure for x captures y
125 m[hp-24] = x_info;
126 // allocate and initialize y
127 m[hp-32] = z; // the closure for y captures z
128 m[hp-40] = y_info;
129 // allocate and initialize z
130 ...
131
132 For each closure, we must generate not only the code to allocate and
133 initialize the closure itself, but also some Initialization Code that
134 sets a variable holding the closure pointer.
135 The complication here is that we don't know the heap offsets a priori,
136 which has two consequences:
137 1. we need a fixpoint
138 2. we can't trivially separate the Initialization Code from the
139 code that compiles the right-hand-sides
140
141 Note: We don't need this complication with let-no-escapes, because
142 in that case, the names are bound to labels in the environment,
143 and we don't need to emit any code to witness that binding.
144 -}
145
146 --------------------
147 cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
148 -- The Id is passed along so a binding can be set up
149 -- The returned values are the binding for the environment
150 -- and the Initialization Code that witnesses the binding
151
152 cgRhs name (StgRhsCon maybe_cc con args)
153 = buildDynCon name maybe_cc con args
154
155 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
156 = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
157
158 ------------------------------------------------------------------------
159 -- Non-constructor right hand sides
160 ------------------------------------------------------------------------
161
162 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
163 -> [NonVoid Id] -- Free vars
164 -> UpdateFlag -> SRT
165 -> [Id] -- Args
166 -> StgExpr
167 -> FCode (CgIdInfo, CmmAGraph)
168
169 {- mkRhsClosure looks for two special forms of the right-hand side:
170 a) selector thunks
171 b) AP thunks
172
173 If neither happens, it just calls mkClosureLFInfo. You might think
174 that mkClosureLFInfo should do all this, but it seems wrong for the
175 latter to look at the structure of an expression
176
177 Note [Selectors]
178 ~~~~~~~~~~~~~~~~
179 We look at the body of the closure to see if it's a selector---turgid,
180 but nothing deep. We are looking for a closure of {\em exactly} the
181 form:
182
183 ... = [the_fv] \ u [] ->
184 case the_fv of
185 con a_1 ... a_n -> a_i
186
187 Note [Ap thunks]
188 ~~~~~~~~~~~~~~~~
189 A more generic AP thunk of the form
190
191 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
192
193 A set of these is compiled statically into the RTS, so we just use
194 those. We could extend the idea to thunks where some of the x_i are
195 global ids (and hence not free variables), but this would entail
196 generating a larger thunk. It might be an option for non-optimising
197 compilation, though.
198
199 We only generate an Ap thunk if all the free variables are pointers,
200 for semi-obvious reasons.
201
202 -}
203
204 ---------- Note [Selectors] ------------------
205 mkRhsClosure bndr cc bi
206 [NonVoid the_fv] -- Just one free var
207 upd_flag -- Updatable thunk
208 _srt
209 [] -- A thunk
210 body@(StgCase (StgApp scrutinee [{-no args-}])
211 _ _ _ _ -- ignore uniq, etc.
212 (AlgAlt _)
213 [(DataAlt _, params, _use_mask,
214 (StgApp selectee [{-no args-}]))])
215 | the_fv == scrutinee -- Scrutinee is the only free variable
216 && maybeToBool maybe_offset -- Selectee is a component of the tuple
217 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
218 = -- NOT TRUE: ASSERT(is_single_constructor)
219 -- The simplifier may have statically determined that the single alternative
220 -- is the only possible case and eliminated the others, even if there are
221 -- other constructors in the datatype. It's still ok to make a selector
222 -- thunk in this case, because we *know* which constructor the scrutinee
223 -- will evaluate to.
224 --
225 -- srt is discarded; it must be empty
226 cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
227 where
228 lf_info = mkSelectorLFInfo bndr offset_into_int
229 (isUpdatable upd_flag)
230 (_, _, params_w_offsets) = mkVirtConstrOffsets (addIdReps params)
231 -- Just want the layout
232 maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
233 Just the_offset = maybe_offset
234 offset_into_int = the_offset - fixedHdrSize
235
236 ---------- Note [Ap thunks] ------------------
237 mkRhsClosure bndr cc bi
238 fvs
239 upd_flag
240 _srt
241 [] -- No args; a thunk
242 body@(StgApp fun_id args)
243
244 | args `lengthIs` (arity-1)
245 && all (isGcPtrRep . idPrimRep . stripNV) fvs
246 && isUpdatable upd_flag
247 && arity <= mAX_SPEC_AP_SIZE
248
249 -- Ha! an Ap thunk
250 = cgStdThunk bndr cc bi body lf_info payload
251 where
252 lf_info = mkApLFInfo bndr upd_flag arity
253 -- the payload has to be in the correct order, hence we can't
254 -- just use the fvs.
255 payload = StgVarArg fun_id : args
256 arity = length fvs
257
258 ---------- Default case ------------------
259 mkRhsClosure bndr cc _ fvs upd_flag srt args body
260 = do { -- LAY OUT THE OBJECT
261 -- If the binder is itself a free variable, then don't store
262 -- it in the closure. Instead, just bind it to Node on entry.
263 -- NB we can be sure that Node will point to it, because we
264 -- haven't told mkClosureLFInfo about this; so if the binder
265 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
266 -- stored in the closure itself, so it will make sure that
267 -- Node points to it...
268 ; let
269 is_elem = isIn "cgRhsClosure"
270 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
271 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
272 | otherwise = fvs
273
274
275 -- MAKE CLOSURE INFO FOR THIS CLOSURE
276 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
277 ; mod_name <- getModuleName
278 ; c_srt <- getSRTInfo srt
279 ; let name = idName bndr
280 descr = closureDescription mod_name name
281 fv_details :: [(NonVoid Id, VirtualHpOffset)]
282 (tot_wds, ptr_wds, fv_details)
283 = mkVirtHeapOffsets (isLFThunk lf_info)
284 (addIdReps (map stripNV reduced_fvs))
285 closure_info = mkClosureInfo False -- Not static
286 bndr lf_info tot_wds ptr_wds
287 c_srt descr
288
289 -- BUILD ITS INFO TABLE AND CODE
290 ; forkClosureBody $
291 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
292 -- (b) ignore Sequel from context; use empty Sequel
293 -- And compile the body
294 closureCodeBody False bndr closure_info cc (nonVoidIds args)
295 (length args) body fv_details
296
297 -- BUILD THE OBJECT
298 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
299 ; emit (mkComment $ mkFastString "calling allocDynClosure")
300 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
301 ; let info_tbl = mkCmmInfo closure_info
302 ; (tmp, init) <- allocDynClosure info_tbl lf_info use_cc blame_cc
303 (map toVarArg fv_details)
304
305 -- RETURN
306 ; regIdInfo bndr lf_info tmp init }
307
308 -- Use with care; if used inappropriately, it could break invariants.
309 stripNV :: NonVoid a -> a
310 stripNV (NonVoid a) = a
311
312 -------------------------
313 cgStdThunk
314 :: Id
315 -> CostCentreStack -- Optional cost centre annotation
316 -> StgBinderInfo -- XXX: not used??
317 -> StgExpr
318 -> LambdaFormInfo
319 -> [StgArg] -- payload
320 -> FCode (CgIdInfo, CmmAGraph)
321
322 cgStdThunk bndr cc _bndr_info body lf_info payload
323 = do -- AHA! A STANDARD-FORM THUNK
324 { -- LAY OUT THE OBJECT
325 mod_name <- getModuleName
326 ; let (tot_wds, ptr_wds, payload_w_offsets)
327 = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
328
329 descr = closureDescription mod_name (idName bndr)
330 closure_info = mkClosureInfo False -- Not static
331 bndr lf_info tot_wds ptr_wds
332 NoC_SRT -- No SRT for a std-form closure
333 descr
334
335 ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
336
337 -- BUILD THE OBJECT
338 ; let info_tbl = mkCmmInfo closure_info
339 ; (tmp, init) <- allocDynClosure info_tbl lf_info
340 use_cc blame_cc payload_w_offsets
341
342 -- RETURN
343 ; regIdInfo bndr lf_info tmp init }
344
345 mkClosureLFInfo :: Id -- The binder
346 -> TopLevelFlag -- True of top level
347 -> [NonVoid Id] -- Free vars
348 -> UpdateFlag -- Update flag
349 -> [Id] -- Args
350 -> FCode LambdaFormInfo
351 mkClosureLFInfo bndr top fvs upd_flag args
352 | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
353 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
354 ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
355
356
357 ------------------------------------------------------------------------
358 -- The code for closures}
359 ------------------------------------------------------------------------
360
361 closureCodeBody :: Bool -- whether this is a top-level binding
362 -> Id -- the closure's name
363 -> ClosureInfo -- Lots of information about this closure
364 -> CostCentreStack -- Optional cost centre attached to closure
365 -> [NonVoid Id] -- incoming args to the closure
366 -> Int -- arity, including void args
367 -> StgExpr
368 -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
369 -> FCode ()
370
371 {- There are two main cases for the code for closures.
372
373 * If there are *no arguments*, then the closure is a thunk, and not in
374 normal form. So it should set up an update frame (if it is
375 shared). NB: Thunks cannot have a primitive type!
376
377 * If there is *at least one* argument, then this closure is in
378 normal form, so there is no need to set up an update frame.
379
380 The Macros for GrAnSim are produced at the beginning of the
381 argSatisfactionCheck (by calling fetchAndReschedule).
382 There info if Node points to closure is available. -- HWL -}
383
384 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
385 | length args == 0 -- No args i.e. thunk
386 = emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
387 \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
388 where
389 lf_info = closureLFInfo cl_info
390 info_tbl = mkCmmInfo cl_info
391
392 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
393 = ASSERT( length args > 0 )
394 do { -- Allocate the global ticky counter,
395 -- and establish the ticky-counter
396 -- label for this block
397 ; let ticky_ctr_lbl = closureRednCountsLabel cl_info
398 ; emitTickyCounter cl_info (map stripNV args)
399 ; setTickyCtrLabel ticky_ctr_lbl $ do
400
401 ; let
402 lf_info = closureLFInfo cl_info
403 info_tbl = mkCmmInfo cl_info
404
405 -- Emit the main entry code
406 ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
407 \(offset, node, arg_regs) -> do
408 -- Emit slow-entry code (for entering a closure through a PAP)
409 { mkSlowEntryCode cl_info arg_regs
410
411 ; let lf_info = closureLFInfo cl_info
412 node_points = nodeMustPointToIt lf_info
413 node' = if node_points then Just node else Nothing
414 ; tickyEnterFun cl_info
415 ; whenC node_points (ldvEnterClosure cl_info)
416 ; granYield arg_regs node_points
417
418 -- Main payload
419 ; entryHeapCheck cl_info offset node' arity arg_regs $ do
420 { enterCostCentre cl_info cc body
421 ; fv_bindings <- mapM bind_fv fv_details
422 -- Load free vars out of closure *after*
423 -- heap check, to reduce live vars over check
424 ; if node_points then load_fvs node lf_info fv_bindings
425 else return ()
426 ; cgExpr body }}
427 }
428
429 -- A function closure pointer may be tagged, so we
430 -- must take it into account when accessing the free variables.
431 bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
432 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
433
434 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
435 load_fvs node lf_info = mapCs (\ (reg, off) ->
436 emit $ mkTaggedObjectLoad reg node off tag)
437 where tag = lfDynTag lf_info
438
439 -----------------------------------------
440 -- The "slow entry" code for a function. This entry point takes its
441 -- arguments on the stack. It loads the arguments into registers
442 -- according to the calling convention, and jumps to the function's
443 -- normal entry point. The function's closure is assumed to be in
444 -- R1/node.
445 --
446 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
447
448 mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
449 -- If this function doesn't have a specialised ArgDescr, we need
450 -- to generate the function's arg bitmap and slow-entry code.
451 -- Here, we emit the slow-entry code.
452 mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
453 mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
454 | Just (_, ArgGen _) <- closureFunInfo cl_info
455 = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
456 | otherwise = return ()
457 where
458 slow_lbl = closureSlowEntryLabel cl_info
459 fast_lbl = closureLocalEntryLabel cl_info
460 -- mkDirectJump does not clobber `Node' containing function closure
461 jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
462 initUpdFrameOff
463
464 -----------------------------------------
465 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
466 -> LocalReg -> Int -> StgExpr -> FCode ()
467 thunkCode cl_info fv_details cc node arity body
468 = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
469 node' = if node_points then Just node else Nothing
470 ; tickyEnterThunk cl_info
471 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
472 ; granThunk node_points
473
474 -- Heap overflow check
475 ; entryHeapCheck cl_info 0 node' arity [] $ do
476 { -- Overwrite with black hole if necessary
477 -- but *after* the heap-overflow check
478 dflags <- getDynFlags
479 ; whenC (blackHoleOnEntry dflags cl_info && node_points)
480 (blackHoleIt cl_info)
481
482 -- Push update frame
483 ; setupUpdate cl_info node $
484 -- We only enter cc after setting up update so
485 -- that cc of enclosing scope will be recorded
486 -- in update frame CAF/DICT functions will be
487 -- subsumed by this enclosing cc
488 do { enterCostCentre cl_info cc body
489 ; let lf_info = closureLFInfo cl_info
490 ; fv_bindings <- mapM bind_fv fv_details
491 ; load_fvs node lf_info fv_bindings
492 ; cgExpr body }}}
493
494
495 ------------------------------------------------------------------------
496 -- Update and black-hole wrappers
497 ------------------------------------------------------------------------
498
499 blackHoleIt :: ClosureInfo -> FCode ()
500 -- Only called for closures with no args
501 -- Node points to the closure
502 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
503
504 emitBlackHoleCode :: Bool -> FCode ()
505 emitBlackHoleCode is_single_entry = do
506 tickyBlackHole (not is_single_entry)
507 emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)))
508 emitPrimCall [] MO_WriteBarrier []
509 emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
510 where
511 bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
512 | otherwise = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info")
513 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
514 -- Nota Bene: this function does not change Node (even if it's a CAF),
515 -- so that the cost centre in the original closure can still be
516 -- extracted by a subsequent enterCostCentre
517 setupUpdate closure_info node body
518 | closureReEntrant closure_info
519 = body
520
521 | not (isStaticClosure closure_info)
522 = if not (closureUpdReqd closure_info)
523 then do tickyUpdateFrameOmitted; body
524 else do
525 tickyPushUpdateFrame
526 --dflags <- getDynFlags
527 let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel]
528 --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
529 -- then pushUpdateFrame es body -- XXX black hole
530 -- else pushUpdateFrame es body
531 pushUpdateFrame es body
532
533 | otherwise -- A static closure
534 = do { tickyUpdateBhCaf closure_info
535
536 ; if closureUpdReqd closure_info
537 then do -- Blackhole the (updatable) CAF:
538 { upd_closure <- link_caf True
539 ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
540 mkLblExpr mkUpdInfoLabel] body } -- XXX black hole
541 else do {tickyUpdateFrameOmitted; body}
542 }
543
544 -----------------------------------------------------------------------------
545 -- Setting up update frames
546
547 -- Push the update frame on the stack in the Entry area,
548 -- leaving room for the return address that is already
549 -- at the old end of the area.
550 pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
551 pushUpdateFrame es body
552 = do -- [EZY] I'm not sure if we need to special-case for BH too
553 updfr <- getUpdFrameOff
554 offset <- foldM push updfr es
555 withUpdFrameOff offset body
556 where push off e =
557 do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
558 return base
559 where base = off + widthInBytes (cmmExprWidth e)
560
561 -----------------------------------------------------------------------------
562 -- Entering a CAF
563 --
564 -- When a CAF is first entered, it creates a black hole in the heap,
565 -- and updates itself with an indirection to this new black hole.
566 --
567 -- We update the CAF with an indirection to a newly-allocated black
568 -- hole in the heap. We also set the blocking queue on the newly
569 -- allocated black hole to be empty.
570 --
571 -- Why do we make a black hole in the heap when we enter a CAF?
572 --
573 -- - for a generational garbage collector, which needs a fast
574 -- test for whether an updatee is in an old generation or not
575 --
576 -- - for the parallel system, which can implement updates more
577 -- easily if the updatee is always in the heap. (allegedly).
578 --
579 -- When debugging, we maintain a separate CAF list so we can tell when
580 -- a CAF has been garbage collected.
581
582 -- newCAF must be called before the itbl ptr is overwritten, since
583 -- newCAF records the old itbl ptr in order to do CAF reverting
584 -- (which Hugs needs to do in order that combined mode works right.)
585 --
586
587 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
588 -- into the "newCAF" RTS procedure, which we call anyway, including
589 -- the allocation of the black-hole indirection closure.
590 -- That way, code size would fall, the CAF-handling code would
591 -- be closer together, and the compiler wouldn't need to know
592 -- about off_indirectee etc.
593
594 link_caf :: Bool -- True <=> updatable, False <=> single-entry
595 -> FCode LocalReg -- Returns amode for closure to be updated
596 -- To update a CAF we must allocate a black hole, link the CAF onto the
597 -- CAF list, then update the CAF to point to the fresh black hole.
598 -- This function returns the address of the black hole, so it can be
599 -- updated with the new value when available. The reason for all of this
600 -- is that we only want to update dynamic heap objects, not static ones,
601 -- so that generational GC is easier.
602 link_caf _is_upd = do
603 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
604 ; let use_cc = costCentreFrom (CmmReg nodeReg)
605 blame_cc = use_cc
606 tso = CmmReg (CmmGlobal CurrentTSO)
607
608 ; (hp_rel, init) <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole
609 use_cc blame_cc [(tso,fixedHdrSize)]
610 ; emit init
611
612 -- Call the RTS function newCAF to add the CAF to the CafList
613 -- so that the garbage collector can find them
614 -- This must be done *before* the info table pointer is overwritten,
615 -- because the old info table ptr is needed for reversion
616 ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
617 [ (CmmReg (CmmGlobal BaseReg), AddrHint),
618 (CmmReg nodeReg, AddrHint) ]
619 [node] False
620 -- node is live, so save it.
621
622 -- Overwrite the closure with a (static) indirection
623 -- to the newly-allocated black hole
624 ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
625 mkStore (CmmReg nodeReg) ind_static_info)
626
627 ; return hp_rel }
628 where
629 ind_static_info :: CmmExpr
630 ind_static_info = mkLblExpr mkIndStaticInfoLabel
631
632 off_indirectee :: WordOff
633 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
634
635
636 ------------------------------------------------------------------------
637 -- Profiling
638 ------------------------------------------------------------------------
639
640 -- For "global" data constructors the description is simply occurrence
641 -- name of the data constructor itself. Otherwise it is determined by
642 -- @closureDescription@ from the let binding information.
643
644 closureDescription :: Module -- Module
645 -> Name -- Id of closure binding
646 -> String
647 -- Not called for StgRhsCon which have global info tables built in
648 -- CgConTbls.lhs with a description generated from the data constructor
649 closureDescription mod_name name
650 = showSDocDump (char '<' <>
651 (if isExternalName name
652 then ppr name -- ppr will include the module name prefix
653 else pprModule mod_name <> char '.' <> ppr name) <>
654 char '>')
655 -- showSDocDump, because we want to see the unique on the Name.
656