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