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