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