never executed always true always false
1 -----------------------------------------------------------------------------
2 --
3 -- Stg to C-- code generation: bindings
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module GHC.StgToCmm.Bind (
10 cgTopRhsClosure,
11 cgBind,
12 emitBlackHoleCode,
13 pushUpdateFrame, emitUpdateFrame
14 ) where
15
16 import GHC.Prelude hiding ((<*>))
17
18 import GHC.Driver.Session
19
20 import GHC.Core ( AltCon(..) )
21 import GHC.Runtime.Heap.Layout
22 import GHC.Unit.Module
23
24 import GHC.Stg.Syntax
25
26 import GHC.Platform
27 import GHC.Platform.Profile
28
29 import GHC.StgToCmm.Expr
30 import GHC.StgToCmm.Monad
31 import GHC.StgToCmm.Env
32 import GHC.StgToCmm.DataCon
33 import GHC.StgToCmm.Heap
34 import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
35 initUpdFrameProf)
36 import GHC.StgToCmm.Ticky
37 import GHC.StgToCmm.Layout
38 import GHC.StgToCmm.Utils
39 import GHC.StgToCmm.Closure
40 import GHC.StgToCmm.Foreign (emitPrimCall)
41
42 import GHC.Cmm.Graph
43 import GHC.Cmm.BlockId
44 import GHC.Cmm
45 import GHC.Cmm.Info
46 import GHC.Cmm.Utils
47 import GHC.Cmm.CLabel
48
49 import GHC.Types.CostCentre
50 import GHC.Types.Id
51 import GHC.Types.Id.Info
52 import GHC.Types.Name
53 import GHC.Types.Var.Set
54 import GHC.Types.Basic
55 import GHC.Types.Tickish ( tickishIsCode )
56
57 import GHC.Utils.Misc
58 import GHC.Utils.Outputable
59 import GHC.Utils.Panic
60
61 import GHC.Data.FastString
62 import GHC.Data.List.SetOps
63
64 import Control.Monad
65
66 ------------------------------------------------------------------------
67 -- Top-level bindings
68 ------------------------------------------------------------------------
69
70 -- For closures bound at top level, allocate in static space.
71 -- They should have no free variables.
72
73 cgTopRhsClosure :: Platform
74 -> RecFlag -- member of a recursive group?
75 -> Id
76 -> CostCentreStack -- Optional cost centre annotation
77 -> UpdateFlag
78 -> [Id] -- Args
79 -> CgStgExpr
80 -> (CgIdInfo, FCode ())
81
82 cgTopRhsClosure platform rec id ccs upd_flag args body =
83 let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
84 cg_id_info = litIdInfo platform id lf_info (CmmLabel closure_label)
85 lf_info = mkClosureLFInfo platform id TopLevel [] upd_flag args
86 in (cg_id_info, gen_code lf_info closure_label)
87 where
88 -- special case for a indirection (f = g). We create an IND_STATIC
89 -- closure pointing directly to the indirectee. This is exactly
90 -- what the CAF will eventually evaluate to anyway, we're just
91 -- shortcutting the whole process, and generating a lot less code
92 -- (#7308). Eventually the IND_STATIC closure will be eliminated
93 -- by assembly '.equiv' directives, where possible (#15155).
94 -- See note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel".
95 --
96 -- Note: we omit the optimisation when this binding is part of a
97 -- recursive group, because the optimisation would inhibit the black
98 -- hole detection from working in that case. Test
99 -- concurrent/should_run/4030 fails, for instance.
100 --
101 gen_code _ closure_label
102 | StgApp f [] <- body, null args, isNonRec rec
103 = do
104 cg_info <- getCgIdInfo f
105 emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
106
107 gen_code lf_info _closure_label
108 = do { profile <- getProfile
109 ; dflags <- getDynFlags
110 ; let name = idName id
111 ; mod_name <- getModuleName
112 ; let descr = closureDescription dflags mod_name name
113 closure_info = mkClosureInfo profile True id lf_info 0 0 descr
114
115 -- We don't generate the static closure here, because we might
116 -- want to add references to static closures to it later. The
117 -- static closure is generated by GHC.Cmm.Info.Build.updInfoSRTs,
118 -- See Note [SRTs], specifically the [FUN] optimisation.
119
120 ; let fv_details :: [(NonVoid Id, ByteOff)]
121 header = if isLFThunk lf_info then ThunkHeader else StdHeader
122 (_, _, fv_details) = mkVirtHeapOffsets profile header []
123 -- Don't drop the non-void args until the closure info has been made
124 ; forkClosureBody (closureCodeBody True id closure_info ccs
125 args body fv_details)
126
127 ; return () }
128
129 unLit (CmmLit l) = l
130 unLit _ = panic "unLit"
131
132 ------------------------------------------------------------------------
133 -- Non-top-level bindings
134 ------------------------------------------------------------------------
135
136 cgBind :: CgStgBinding -> FCode ()
137 cgBind (StgNonRec name rhs)
138 = do { (info, fcode) <- cgRhs name rhs
139 ; addBindC info
140 ; init <- fcode
141 ; emit init }
142 -- init cannot be used in body, so slightly better to sink it eagerly
143
144 cgBind (StgRec pairs)
145 = do { r <- sequence $ unzipWith cgRhs pairs
146 ; let (id_infos, fcodes) = unzip r
147 ; addBindsC id_infos
148 ; (inits, body) <- getCodeR $ sequence fcodes
149 ; emit (catAGraphs inits <*> body) }
150
151 {- Note [cgBind rec]
152
153 Recursive let-bindings are tricky.
154 Consider the following pseudocode:
155
156 let x = \_ -> ... y ...
157 y = \_ -> ... z ...
158 z = \_ -> ... x ...
159 in ...
160
161 For each binding, we need to allocate a closure, and each closure must
162 capture the address of the other closures.
163 We want to generate the following C-- code:
164 // Initialization Code
165 x = hp - 24; // heap address of x's closure
166 y = hp - 40; // heap address of x's closure
167 z = hp - 64; // heap address of x's closure
168 // allocate and initialize x
169 m[hp-8] = ...
170 m[hp-16] = y // the closure for x captures y
171 m[hp-24] = x_info;
172 // allocate and initialize y
173 m[hp-32] = z; // the closure for y captures z
174 m[hp-40] = y_info;
175 // allocate and initialize z
176 ...
177
178 For each closure, we must generate not only the code to allocate and
179 initialize the closure itself, but also some initialization Code that
180 sets a variable holding the closure pointer.
181
182 We could generate a pair of the (init code, body code), but since
183 the bindings are recursive we also have to initialise the
184 environment with the CgIdInfo for all the bindings before compiling
185 anything. So we do this in 3 stages:
186
187 1. collect all the CgIdInfos and initialise the environment
188 2. compile each binding into (init, body) code
189 3. emit all the inits, and then all the bodies
190
191 We'd rather not have separate functions to do steps 1 and 2 for
192 each binding, since in practice they share a lot of code. So we
193 have just one function, cgRhs, that returns a pair of the CgIdInfo
194 for step 1, and a monadic computation to generate the code in step
195 2.
196
197 The alternative to separating things in this way is to use a
198 fixpoint. That's what we used to do, but it introduces a
199 maintenance nightmare because there is a subtle dependency on not
200 being too strict everywhere. Doing things this way means that the
201 FCode monad can be strict, for example.
202 -}
203
204 cgRhs :: Id
205 -> CgStgRhs
206 -> FCode (
207 CgIdInfo -- The info for this binding
208 , FCode CmmAGraph -- A computation which will generate the
209 -- code for the binding, and return an
210 -- assignment of the form "x = Hp - n"
211 -- (see above)
212 )
213
214 cgRhs id (StgRhsCon cc con mn _ts args)
215 = withNewTickyCounterCon (idName id) con $
216 buildDynCon id mn True cc con (assertNonVoidStgArgs args)
217 -- con args are always non-void,
218 -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
219
220 {- See Note [GC recovery] in "GHC.StgToCmm.Closure" -}
221 cgRhs id (StgRhsClosure fvs cc upd_flag args body)
222 = do profile <- getProfile
223 mkRhsClosure profile id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
224
225 ------------------------------------------------------------------------
226 -- Non-constructor right hand sides
227 ------------------------------------------------------------------------
228
229 mkRhsClosure :: Profile -> Id -> CostCentreStack
230 -> [NonVoid Id] -- Free vars
231 -> UpdateFlag
232 -> [Id] -- Args
233 -> CgStgExpr
234 -> FCode (CgIdInfo, FCode CmmAGraph)
235
236 {- mkRhsClosure looks for two special forms of the right-hand side:
237 a) selector thunks
238 b) AP thunks
239
240 If neither happens, it just calls mkClosureLFInfo. You might think
241 that mkClosureLFInfo should do all this, but it seems wrong for the
242 latter to look at the structure of an expression
243
244 Note [Selectors]
245 ~~~~~~~~~~~~~~~~
246 We look at the body of the closure to see if it's a selector---turgid,
247 but nothing deep. We are looking for a closure of {\em exactly} the
248 form:
249
250 ... = [the_fv] \ u [] ->
251 case the_fv of
252 con a_1 ... a_n -> a_i
253
254 Note [Ap thunks]
255 ~~~~~~~~~~~~~~~~
256 A more generic AP thunk of the form
257
258 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
259
260 A set of these is compiled statically into the RTS, so we just use
261 those. We could extend the idea to thunks where some of the x_i are
262 global ids (and hence not free variables), but this would entail
263 generating a larger thunk. It might be an option for non-optimising
264 compilation, though.
265
266 We only generate an Ap thunk if all the free variables are pointers,
267 for semi-obvious reasons.
268
269 -}
270
271 ---------- Note [Selectors] ------------------
272 mkRhsClosure profile bndr _cc
273 [NonVoid the_fv] -- Just one free var
274 upd_flag -- Updatable thunk
275 [] -- A thunk
276 expr
277 | let strip = stripStgTicksTopE (not . tickishIsCode)
278 , StgCase (StgApp scrutinee [{-no args-}])
279 _ -- ignore bndr
280 (AlgAlt _)
281 [(DataAlt _, params, sel_expr)] <- strip expr
282 , StgApp selectee [{-no args-}] <- strip sel_expr
283 , the_fv == scrutinee -- Scrutinee is the only free variable
284
285 , let (_, _, params_w_offsets) = mkVirtConstrOffsets profile (addIdReps (assertNonVoidIds params))
286 -- pattern binders are always non-void,
287 -- see Note [Post-unarisation invariants] in GHC.Stg.Unarise
288 , Just the_offset <- assocMaybe params_w_offsets (NonVoid selectee)
289
290 , let offset_into_int = bytesToWordsRoundUp (profilePlatform profile) the_offset
291 - fixedHdrSizeW profile
292 , offset_into_int <= pc_MAX_SPEC_SELECTEE_SIZE (profileConstants profile) -- Offset is small enough
293 = -- NOT TRUE: assert (is_single_constructor)
294 -- The simplifier may have statically determined that the single alternative
295 -- is the only possible case and eliminated the others, even if there are
296 -- other constructors in the datatype. It's still ok to make a selector
297 -- thunk in this case, because we *know* which constructor the scrutinee
298 -- will evaluate to.
299 --
300 -- srt is discarded; it must be empty
301 let lf_info = mkSelectorLFInfo bndr offset_into_int (isUpdatable upd_flag)
302 in cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
303
304 ---------- Note [Ap thunks] ------------------
305 mkRhsClosure profile bndr _cc
306 fvs
307 upd_flag
308 [] -- No args; a thunk
309 (StgApp fun_id args)
310
311 -- We are looking for an "ApThunk"; see data con ApThunk in GHC.StgToCmm.Closure
312 -- of form (x1 x2 .... xn), where all the xi are locals (not top-level)
313 -- So the xi will all be free variables
314 | args `lengthIs` (n_fvs-1) -- This happens only if the fun_id and
315 -- args are all distinct local variables
316 -- The "-1" is for fun_id
317 -- Missed opportunity: (f x x) is not detected
318 , all (isGcPtrRep . idPrimRep . fromNonVoid) fvs
319 , isUpdatable upd_flag
320 , n_fvs <= pc_MAX_SPEC_AP_SIZE (profileConstants profile)
321 , not (profileIsProfiling profile)
322 -- not when profiling: we don't want to
323 -- lose information about this particular
324 -- thunk (e.g. its type) (#949)
325 , idArity fun_id == unknownArity -- don't spoil a known call
326
327 -- Ha! an Ap thunk
328 = cgRhsStdThunk bndr lf_info payload
329
330 where
331 n_fvs = length fvs
332 lf_info = mkApLFInfo bndr upd_flag n_fvs
333 -- the payload has to be in the correct order, hence we can't
334 -- just use the fvs.
335 payload = StgVarArg fun_id : args
336
337 ---------- Default case ------------------
338 mkRhsClosure profile bndr cc fvs upd_flag args body
339 = do { let lf_info = mkClosureLFInfo (profilePlatform profile) bndr NotTopLevel fvs upd_flag args
340 ; (id_info, reg) <- rhsIdInfo bndr lf_info
341 ; return (id_info, gen_code lf_info reg) }
342 where
343 gen_code lf_info reg
344 = do { -- LAY OUT THE OBJECT
345 -- If the binder is itself a free variable, then don't store
346 -- it in the closure. Instead, just bind it to Node on entry.
347 -- NB we can be sure that Node will point to it, because we
348 -- haven't told mkClosureLFInfo about this; so if the binder
349 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
350 -- stored in the closure itself, so it will make sure that
351 -- Node points to it...
352 ; let reduced_fvs = filter (NonVoid bndr /=) fvs
353
354 ; profile <- getProfile
355 ; let platform = profilePlatform profile
356
357 -- MAKE CLOSURE INFO FOR THIS CLOSURE
358 ; mod_name <- getModuleName
359 ; dflags <- getDynFlags
360 ; let name = idName bndr
361 descr = closureDescription dflags mod_name name
362 fv_details :: [(NonVoid Id, ByteOff)]
363 header = if isLFThunk lf_info then ThunkHeader else StdHeader
364 (tot_wds, ptr_wds, fv_details)
365 = mkVirtHeapOffsets profile header (addIdReps reduced_fvs)
366 closure_info = mkClosureInfo profile False -- Not static
367 bndr lf_info tot_wds ptr_wds
368 descr
369
370 -- BUILD ITS INFO TABLE AND CODE
371 ; forkClosureBody $
372 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
373 -- (b) ignore Sequel from context; use empty Sequel
374 -- And compile the body
375 closureCodeBody False bndr closure_info cc args
376 body fv_details
377
378 -- BUILD THE OBJECT
379 -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
380 ; let use_cc = cccsExpr; blame_cc = cccsExpr
381 ; emit (mkComment $ mkFastString "calling allocDynClosure")
382 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
383 ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
384 ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
385 (map toVarArg fv_details)
386
387 -- RETURN
388 ; return (mkRhsInit platform reg lf_info hp_plus_n) }
389
390 -------------------------
391 cgRhsStdThunk
392 :: Id
393 -> LambdaFormInfo
394 -> [StgArg] -- payload
395 -> FCode (CgIdInfo, FCode CmmAGraph)
396
397 cgRhsStdThunk bndr lf_info payload
398 = do { (id_info, reg) <- rhsIdInfo bndr lf_info
399 ; return (id_info, gen_code reg)
400 }
401 where
402 gen_code reg -- AHA! A STANDARD-FORM THUNK
403 = withNewTickyCounterStdThunk (lfUpdatable lf_info) (idName bndr) $
404 do
405 { -- LAY OUT THE OBJECT
406 mod_name <- getModuleName
407 ; dflags <- getDynFlags
408 ; profile <- getProfile
409 ; let platform = profilePlatform profile
410 header = if isLFThunk lf_info then ThunkHeader else StdHeader
411 (tot_wds, ptr_wds, payload_w_offsets)
412 = mkVirtHeapOffsets profile header
413 (addArgReps (nonVoidStgArgs payload))
414
415 descr = closureDescription dflags mod_name (idName bndr)
416 closure_info = mkClosureInfo profile False -- Not static
417 bndr lf_info tot_wds ptr_wds
418 descr
419
420 -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
421 ; let use_cc = cccsExpr; blame_cc = cccsExpr
422
423
424 -- BUILD THE OBJECT
425 ; let info_tbl = mkCmmInfo closure_info bndr currentCCS
426 ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
427 use_cc blame_cc payload_w_offsets
428
429 -- RETURN
430 ; return (mkRhsInit platform reg lf_info hp_plus_n) }
431
432
433 mkClosureLFInfo :: Platform
434 -> Id -- The binder
435 -> TopLevelFlag -- True of top level
436 -> [NonVoid Id] -- Free vars
437 -> UpdateFlag -- Update flag
438 -> [Id] -- Args
439 -> LambdaFormInfo
440 mkClosureLFInfo platform bndr top fvs upd_flag args
441 | null args =
442 mkLFThunk (idType bndr) top (map fromNonVoid fvs) upd_flag
443 | otherwise =
444 mkLFReEntrant top (map fromNonVoid fvs) args (mkArgDescr platform args)
445
446
447 ------------------------------------------------------------------------
448 -- The code for closures
449 ------------------------------------------------------------------------
450
451 closureCodeBody :: Bool -- whether this is a top-level binding
452 -> Id -- the closure's name
453 -> ClosureInfo -- Lots of information about this closure
454 -> CostCentreStack -- Optional cost centre attached to closure
455 -> [Id] -- incoming args to the closure
456 -> CgStgExpr
457 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
458 -> FCode ()
459
460 {- There are two main cases for the code for closures.
461
462 * If there are *no arguments*, then the closure is a thunk, and not in
463 normal form. So it should set up an update frame (if it is
464 shared). NB: Thunks cannot have a primitive type!
465
466 * If there is *at least one* argument, then this closure is in
467 normal form, so there is no need to set up an update frame.
468 -}
469
470 -- No args i.e. thunk
471 closureCodeBody top_lvl bndr cl_info cc [] body fv_details
472 = withNewTickyCounterThunk
473 (isStaticClosure cl_info)
474 (closureUpdReqd cl_info)
475 (closureName cl_info) $
476 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
477 \(_, node, _) -> thunkCode cl_info fv_details cc node body
478 where
479 lf_info = closureLFInfo cl_info
480 info_tbl = mkCmmInfo cl_info bndr cc
481
482 closureCodeBody top_lvl bndr cl_info cc args@(arg0:_) body fv_details
483 = let nv_args = nonVoidIds args
484 arity = length args
485 in
486 -- See Note [OneShotInfo overview] in GHC.Types.Basic.
487 withNewTickyCounterFun (isOneShotBndr arg0) (closureName cl_info)
488 nv_args $ do {
489
490 ; let
491 lf_info = closureLFInfo cl_info
492 info_tbl = mkCmmInfo cl_info bndr cc
493
494 -- Emit the main entry code
495 ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl nv_args $
496 \(_offset, node, arg_regs) -> do
497 -- Emit slow-entry code (for entering a closure through a PAP)
498 { mkSlowEntryCode bndr cl_info arg_regs
499 ; profile <- getProfile
500 ; platform <- getPlatform
501 ; let node_points = nodeMustPointToIt profile lf_info
502 node' = if node_points then Just node else Nothing
503 ; loop_header_id <- newBlockId
504 -- Extend reader monad with information that
505 -- self-recursive tail calls can be optimized into local
506 -- jumps. See Note [Self-recursive tail calls] in GHC.StgToCmm.Expr.
507 ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
508 {
509 -- Main payload
510 ; entryHeapCheck cl_info node' arity arg_regs $ do
511 { -- emit LDV code when profiling
512 when node_points (ldvEnterClosure cl_info (CmmLocal node))
513 -- ticky after heap check to avoid double counting
514 ; tickyEnterFun cl_info
515 ; enterCostCentreFun cc
516 (CmmMachOp (mo_wordSub platform)
517 [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
518 , mkIntExpr platform (funTag platform cl_info) ])
519 ; fv_bindings <- mapM bind_fv fv_details
520 -- Load free vars out of closure *after*
521 -- heap check, to reduce live vars over check
522 ; when node_points $ load_fvs node lf_info fv_bindings
523 ; void $ cgExpr body
524 }}}
525
526 }
527
528 -- Note [NodeReg clobbered with loopification]
529 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
530 --
531 -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
532 -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
533 -- may get clobbered inside the body of a closure, and since a self-recursive
534 -- tail call does not restore R1, a subsequent call to enterFunCCS received a
535 -- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
536 -- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
537 -- the original value of R1. This way R1 may get modified but loopification will
538 -- not care.
539
540 -- A function closure pointer may be tagged, so we
541 -- must take it into account when accessing the free variables.
542 bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
543 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
544
545 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
546 load_fvs node lf_info = mapM_ (\ (reg, off) ->
547 do platform <- getPlatform
548 let tag = lfDynTag platform lf_info
549 emit $ mkTaggedObjectLoad platform reg node off tag)
550
551 -----------------------------------------
552 -- The "slow entry" code for a function. This entry point takes its
553 -- arguments on the stack. It loads the arguments into registers
554 -- according to the calling convention, and jumps to the function's
555 -- normal entry point. The function's closure is assumed to be in
556 -- R1/node.
557 --
558 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
559
560 mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
561 -- If this function doesn't have a specialised ArgDescr, we need
562 -- to generate the function's arg bitmap and slow-entry code.
563 -- Here, we emit the slow-entry code.
564 mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
565 | Just (_, ArgGen _) <- closureFunInfo cl_info
566 = do profile <- getProfile
567 platform <- getPlatform
568 let node = idToReg platform (NonVoid bndr)
569 slow_lbl = closureSlowEntryLabel platform cl_info
570 fast_lbl = closureLocalEntryLabel platform cl_info
571 -- mkDirectJump does not clobber `Node' containing function closure
572 jump = mkJump profile NativeNodeCall
573 (mkLblExpr fast_lbl)
574 (map (CmmReg . CmmLocal) (node : arg_regs))
575 (initUpdFrameOff platform)
576 tscope <- getTickScope
577 emitProcWithConvention Slow Nothing slow_lbl
578 (node : arg_regs) (jump, tscope)
579 | otherwise = return ()
580
581 -----------------------------------------
582 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
583 -> LocalReg -> CgStgExpr -> FCode ()
584 thunkCode cl_info fv_details _cc node body
585 = do { profile <- getProfile
586 ; let node_points = nodeMustPointToIt profile (closureLFInfo cl_info)
587 node' = if node_points then Just node else Nothing
588 ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
589
590 -- Heap overflow check
591 ; entryHeapCheck cl_info node' 0 [] $ do
592 { -- Overwrite with black hole if necessary
593 -- but *after* the heap-overflow check
594 ; tickyEnterThunk cl_info
595 ; when (blackHoleOnEntry cl_info && node_points)
596 (blackHoleIt node)
597
598 -- Push update frame
599 ; setupUpdate cl_info node $
600 -- We only enter cc after setting up update so
601 -- that cc of enclosing scope will be recorded
602 -- in update frame CAF/DICT functions will be
603 -- subsumed by this enclosing cc
604 do { enterCostCentreThunk (CmmReg nodeReg)
605 ; let lf_info = closureLFInfo cl_info
606 ; fv_bindings <- mapM bind_fv fv_details
607 ; load_fvs node lf_info fv_bindings
608 ; void $ cgExpr body }}}
609
610
611 ------------------------------------------------------------------------
612 -- Update and black-hole wrappers
613 ------------------------------------------------------------------------
614
615 blackHoleIt :: LocalReg -> FCode ()
616 -- Only called for closures with no args
617 -- Node points to the closure
618 blackHoleIt node_reg
619 = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
620
621 emitBlackHoleCode :: CmmExpr -> FCode ()
622 emitBlackHoleCode node = do
623 dflags <- getDynFlags
624 profile <- getProfile
625 let platform = profilePlatform profile
626
627 -- Eager blackholing is normally disabled, but can be turned on with
628 -- -feager-blackholing. When it is on, we replace the info pointer
629 -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
630
631 -- If we wanted to do eager blackholing with slop filling, we'd need
632 -- to do it at the *end* of a basic block, otherwise we overwrite
633 -- the free variables in the thunk that we still need. We have a
634 -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
635 -- [6/2004]
636 --
637 -- Previously, eager blackholing was enabled when ticky-ticky was
638 -- on. But it didn't work, and it wasn't strictly necessary to bring
639 -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
640 -- unconditionally disabled. -- krc 1/2007
641
642 -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
643 -- because emitBlackHoleCode is called from GHC.Cmm.Parser.
644
645 let eager_blackholing = not (profileIsProfiling profile)
646 && gopt Opt_EagerBlackHoling dflags
647 -- Profiling needs slop filling (to support LDV
648 -- profiling), so currently eager blackholing doesn't
649 -- work with profiling.
650
651 when eager_blackholing $ do
652 whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node
653 emitStore (cmmOffsetW platform node (fixedHdrSizeW profile)) currentTSOExpr
654 -- See Note [Heap memory barriers] in SMP.h.
655 emitPrimCall [] MO_WriteBarrier []
656 emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
657
658 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
659 -- Nota Bene: this function does not change Node (even if it's a CAF),
660 -- so that the cost centre in the original closure can still be
661 -- extracted by a subsequent enterCostCentre
662 setupUpdate closure_info node body
663 | not (lfUpdatable (closureLFInfo closure_info))
664 = body
665
666 | not (isStaticClosure closure_info)
667 = if not (closureUpdReqd closure_info)
668 then do tickyUpdateFrameOmitted; body
669 else do
670 tickyPushUpdateFrame
671 dflags <- getDynFlags
672 let
673 bh = blackHoleOnEntry closure_info &&
674 not (sccProfilingEnabled dflags) &&
675 gopt Opt_EagerBlackHoling dflags
676
677 lbl | bh = mkBHUpdInfoLabel
678 | otherwise = mkUpdInfoLabel
679
680 pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
681
682 | otherwise -- A static closure
683 = do { tickyUpdateBhCaf closure_info
684
685 ; if closureUpdReqd closure_info
686 then do -- Blackhole the (updatable) CAF:
687 { upd_closure <- link_caf node
688 ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
689 else do {tickyUpdateFrameOmitted; body}
690 }
691
692 -----------------------------------------------------------------------------
693 -- Setting up update frames
694
695 -- Push the update frame on the stack in the Entry area,
696 -- leaving room for the return address that is already
697 -- at the old end of the area.
698 --
699 pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
700 pushUpdateFrame lbl updatee body
701 = do
702 updfr <- getUpdFrameOff
703 profile <- getProfile
704 let
705 hdr = fixedHdrSize profile
706 frame = updfr + hdr + pc_SIZEOF_StgUpdateFrame_NoHdr (profileConstants profile)
707 --
708 emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
709 withUpdFrameOff frame body
710
711 emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
712 emitUpdateFrame frame lbl updatee = do
713 profile <- getProfile
714 let
715 hdr = fixedHdrSize profile
716 off_updatee = hdr + pc_OFFSET_StgUpdateFrame_updatee (platformConstants platform)
717 platform = profilePlatform profile
718 --
719 emitStore frame (mkLblExpr lbl)
720 emitStore (cmmOffset platform frame off_updatee) updatee
721 initUpdFrameProf frame
722
723 -----------------------------------------------------------------------------
724 -- Entering a CAF
725 --
726 -- See Note [CAF management] in rts/sm/Storage.c
727
728 link_caf :: LocalReg -- pointer to the closure
729 -> FCode CmmExpr -- Returns amode for closure to be updated
730 -- This function returns the address of the black hole, so it can be
731 -- updated with the new value when available.
732 link_caf node = do
733 { profile <- getProfile
734 -- Call the RTS function newCAF, returning the newly-allocated
735 -- blackhole indirection closure
736 ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
737 ForeignLabelInExternalPackage IsFunction
738 ; let platform = profilePlatform profile
739 ; bh <- newTemp (bWord platform)
740 ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
741 [ (baseExpr, AddrHint),
742 (CmmReg (CmmLocal node), AddrHint) ]
743 False
744
745 -- see Note [atomic CAF entry] in rts/sm/Storage.c
746 ; updfr <- getUpdFrameOff
747 ; ptr_opts <- getPtrOpts
748 ; let target = entryCode platform (closureInfoPtr ptr_opts (CmmReg (CmmLocal node)))
749 ; emit =<< mkCmmIfThen
750 (cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))
751 -- re-enter the CAF
752 (mkJump profile NativeNodeCall target [] updfr)
753
754 ; return (CmmReg (CmmLocal bh)) }
755
756 ------------------------------------------------------------------------
757 -- Profiling
758 ------------------------------------------------------------------------
759
760 -- For "global" data constructors the description is simply occurrence
761 -- name of the data constructor itself. Otherwise it is determined by
762 -- @closureDescription@ from the let binding information.
763
764 closureDescription
765 :: DynFlags
766 -> Module -- Module
767 -> Name -- Id of closure binding
768 -> String
769 -- Not called for StgRhsCon which have global info tables built in
770 -- CgConTbls.hs with a description generated from the data constructor
771 closureDescription dflags mod_name name
772 = let ctx = initSDocContext dflags defaultDumpStyle
773 -- defaultDumpStyle, because we want to see the unique on the Name.
774 in renderWithContext ctx (char '<' <>
775 (if isExternalName name
776 then ppr name -- ppr will include the module name prefix
777 else pprModule mod_name <> char '.' <> ppr name) <>
778 char '>')