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