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