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