Remove unused LiveVars and SRT fields of StgCase and StgLetNoEscape
[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 SMRep
36 import Cmm
37 import CmmInfo
38 import CmmUtils
39 import CLabel
40 import StgSyn
41 import CostCentre
42 import Id
43 import IdInfo
44 import Name
45 import Module
46 import ListSetOps
47 import Util
48 import BasicTypes
49 import Outputable
50 import FastString
51 import DynFlags
52
53 import Control.Monad
54
55 import Prelude hiding ((<*>))
56
57 ------------------------------------------------------------------------
58 -- Top-level bindings
59 ------------------------------------------------------------------------
60
61 -- For closures bound at top level, allocate in static space.
62 -- They should have no free variables.
63
64 cgTopRhsClosure :: DynFlags
65 -> RecFlag -- member of a recursive group?
66 -> Id
67 -> CostCentreStack -- Optional cost centre annotation
68 -> StgBinderInfo
69 -> UpdateFlag
70 -> [Id] -- Args
71 -> StgExpr
72 -> (CgIdInfo, FCode ())
73
74 cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
75 let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
76 cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)
77 lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args
78 in (cg_id_info, gen_code dflags lf_info closure_label)
79 where
80 -- special case for a indirection (f = g). We create an IND_STATIC
81 -- closure pointing directly to the indirectee. This is exactly
82 -- what the CAF will eventually evaluate to anyway, we're just
83 -- shortcutting the whole process, and generating a lot less code
84 -- (#7308)
85 --
86 -- Note: we omit the optimisation when this binding is part of a
87 -- recursive group, because the optimisation would inhibit the black
88 -- hole detection from working in that case. Test
89 -- concurrent/should_run/4030 fails, for instance.
90 --
91 gen_code dflags _ closure_label
92 | StgApp f [] <- body, null args, isNonRec rec
93 = do
94 cg_info <- getCgIdInfo f
95 let closure_rep = mkStaticClosureFields dflags
96 indStaticInfoTable ccs MayHaveCafRefs
97 [unLit (idInfoToAmode cg_info)]
98 emitDataLits closure_label closure_rep
99 return ()
100
101 gen_code dflags lf_info closure_label
102 = do { -- LAY OUT THE OBJECT
103 let name = idName id
104 ; mod_name <- getModuleName
105 ; let descr = closureDescription dflags mod_name name
106 closure_info = mkClosureInfo dflags True id lf_info 0 0 descr
107
108 caffy = idCafInfo id
109 info_tbl = mkCmmInfo closure_info -- XXX short-cut
110 closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy []
111
112 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
113 ; emitDataLits closure_label closure_rep
114 ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
115 (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
116 (addIdReps [])
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 = withNewTickyCounterThunk False (idName id) $ -- False for "not static"
210 buildDynCon id True cc con args
211
212 {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
213 cgRhs name (StgRhsClosure cc bi fvs upd_flag args body)
214 = do dflags <- getDynFlags
215 mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body
216
217 ------------------------------------------------------------------------
218 -- Non-constructor right hand sides
219 ------------------------------------------------------------------------
220
221 mkRhsClosure :: DynFlags -> Id -> CostCentreStack -> StgBinderInfo
222 -> [NonVoid Id] -- Free vars
223 -> UpdateFlag
224 -> [Id] -- Args
225 -> StgExpr
226 -> FCode (CgIdInfo, FCode CmmAGraph)
227
228 {- mkRhsClosure looks for two special forms of the right-hand side:
229 a) selector thunks
230 b) AP thunks
231
232 If neither happens, it just calls mkClosureLFInfo. You might think
233 that mkClosureLFInfo should do all this, but it seems wrong for the
234 latter to look at the structure of an expression
235
236 Note [Selectors]
237 ~~~~~~~~~~~~~~~~
238 We look at the body of the closure to see if it's a selector---turgid,
239 but nothing deep. We are looking for a closure of {\em exactly} the
240 form:
241
242 ... = [the_fv] \ u [] ->
243 case the_fv of
244 con a_1 ... a_n -> a_i
245
246 Note [Ap thunks]
247 ~~~~~~~~~~~~~~~~
248 A more generic AP thunk of the form
249
250 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
251
252 A set of these is compiled statically into the RTS, so we just use
253 those. We could extend the idea to thunks where some of the x_i are
254 global ids (and hence not free variables), but this would entail
255 generating a larger thunk. It might be an option for non-optimising
256 compilation, though.
257
258 We only generate an Ap thunk if all the free variables are pointers,
259 for semi-obvious reasons.
260
261 -}
262
263 ---------- Note [Selectors] ------------------
264 mkRhsClosure dflags bndr _cc _bi
265 [NonVoid the_fv] -- Just one free var
266 upd_flag -- Updatable thunk
267 [] -- A thunk
268 expr
269 | let strip = snd . stripStgTicksTop (not . tickishIsCode)
270 , StgCase (StgApp scrutinee [{-no args-}])
271 _ -- ignore bndr
272 (AlgAlt _)
273 [(DataAlt _, params, _use_mask, sel_expr)] <- strip expr
274 , StgApp selectee [{-no args-}] <- strip sel_expr
275 , the_fv == scrutinee -- Scrutinee is the only free variable
276
277 , let (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
278 -- Just want the layout
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 | args `lengthIs` (arity-1)
303 && all (isGcPtrRep . idPrimRep . unsafe_stripNV) fvs
304 && isUpdatable upd_flag
305 && arity <= mAX_SPEC_AP_SIZE dflags
306 && not (gopt Opt_SccProfilingOn dflags)
307 -- not when profiling: we don't want to
308 -- lose information about this particular
309 -- thunk (e.g. its type) (#949)
310
311 -- Ha! an Ap thunk
312 = cgRhsStdThunk bndr lf_info payload
313
314 where
315 lf_info = mkApLFInfo bndr upd_flag arity
316 -- the payload has to be in the correct order, hence we can't
317 -- just use the fvs.
318 payload = StgVarArg fun_id : args
319 arity = length fvs
320
321 ---------- Default case ------------------
322 mkRhsClosure dflags bndr cc _ fvs upd_flag args body
323 = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args
324 ; (id_info, reg) <- rhsIdInfo bndr lf_info
325 ; return (id_info, gen_code lf_info reg) }
326 where
327 gen_code lf_info reg
328 = do { -- LAY OUT THE OBJECT
329 -- If the binder is itself a free variable, then don't store
330 -- it in the closure. Instead, just bind it to Node on entry.
331 -- NB we can be sure that Node will point to it, because we
332 -- haven't told mkClosureLFInfo about this; so if the binder
333 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
334 -- stored in the closure itself, so it will make sure that
335 -- Node points to it...
336 ; let
337 is_elem = isIn "cgRhsClosure"
338 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
339 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
340 | otherwise = fvs
341
342
343 -- MAKE CLOSURE INFO FOR THIS CLOSURE
344 ; mod_name <- getModuleName
345 ; dflags <- getDynFlags
346 ; let name = idName bndr
347 descr = closureDescription dflags mod_name name
348 fv_details :: [(NonVoid Id, ByteOff)]
349 (tot_wds, ptr_wds, fv_details)
350 = mkVirtHeapOffsets dflags (isLFThunk lf_info)
351 (addIdReps (map unsafe_stripNV reduced_fvs))
352 closure_info = mkClosureInfo dflags False -- Not static
353 bndr lf_info tot_wds ptr_wds
354 descr
355
356 -- BUILD ITS INFO TABLE AND CODE
357 ; forkClosureBody $
358 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
359 -- (b) ignore Sequel from context; use empty Sequel
360 -- And compile the body
361 closureCodeBody False bndr closure_info cc (nonVoidIds args)
362 (length args) body fv_details
363
364 -- BUILD THE OBJECT
365 -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
366 ; let use_cc = curCCS; blame_cc = curCCS
367 ; emit (mkComment $ mkFastString "calling allocDynClosure")
368 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
369 ; let info_tbl = mkCmmInfo closure_info
370 ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
371 (map toVarArg fv_details)
372
373 -- RETURN
374 ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
375
376 -------------------------
377 cgRhsStdThunk
378 :: Id
379 -> LambdaFormInfo
380 -> [StgArg] -- payload
381 -> FCode (CgIdInfo, FCode CmmAGraph)
382
383 cgRhsStdThunk bndr lf_info payload
384 = do { (id_info, reg) <- rhsIdInfo bndr lf_info
385 ; return (id_info, gen_code reg)
386 }
387 where
388 gen_code reg -- AHA! A STANDARD-FORM THUNK
389 = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static"
390 do
391 { -- LAY OUT THE OBJECT
392 mod_name <- getModuleName
393 ; dflags <- getDynFlags
394 ; let (tot_wds, ptr_wds, payload_w_offsets)
395 = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
396
397 descr = closureDescription dflags mod_name (idName bndr)
398 closure_info = mkClosureInfo dflags False -- Not static
399 bndr lf_info tot_wds ptr_wds
400 descr
401
402 -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
403 ; let use_cc = curCCS; blame_cc = curCCS
404
405 ; tickyEnterStdThunk closure_info
406
407 -- BUILD THE OBJECT
408 ; let info_tbl = mkCmmInfo closure_info
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 unsafe_stripNV fvs) upd_flag
426 | otherwise =
427 mkLFReEntrant top (map unsafe_stripNV 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 -> StgExpr
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 (isStaticClosure cl_info) (closureName cl_info) $
457 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
458 \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
459 where
460 lf_info = closureLFInfo cl_info
461 info_tbl = mkCmmInfo cl_info
462
463 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
464 = -- Note: args may be [], if all args are Void
465 withNewTickyCounterFun (closureName cl_info) args $ do {
466
467 ; let
468 lf_info = closureLFInfo cl_info
469 info_tbl = mkCmmInfo cl_info
470
471 -- Emit the main entry code
472 ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
473 \(_offset, node, arg_regs) -> do
474 -- Emit slow-entry code (for entering a closure through a PAP)
475 { mkSlowEntryCode bndr cl_info arg_regs
476 ; dflags <- getDynFlags
477 ; let node_points = nodeMustPointToIt dflags lf_info
478 node' = if node_points then Just node else Nothing
479 ; loop_header_id <- newLabelC
480 -- Extend reader monad with information that
481 -- self-recursive tail calls can be optimized into local
482 -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
483 ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
484 {
485 -- Main payload
486 ; entryHeapCheck cl_info node' arity arg_regs $ do
487 { -- emit LDV code when profiling
488 when node_points (ldvEnterClosure cl_info (CmmLocal node))
489 -- ticky after heap check to avoid double counting
490 ; tickyEnterFun cl_info
491 ; enterCostCentreFun cc
492 (CmmMachOp (mo_wordSub dflags)
493 [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
494 , mkIntExpr dflags (funTag dflags cl_info) ])
495 ; fv_bindings <- mapM bind_fv fv_details
496 -- Load free vars out of closure *after*
497 -- heap check, to reduce live vars over check
498 ; when node_points $ load_fvs node lf_info fv_bindings
499 ; void $ cgExpr body
500 }}}
501
502 }
503
504 -- Note [NodeReg clobbered with loopification]
505 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
506 --
507 -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
508 -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
509 -- may get clobbered inside the body of a closure, and since a self-recursive
510 -- tail call does not restore R1, a subsequent call to enterFunCCS received a
511 -- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
512 -- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
513 -- the original value of R1. This way R1 may get modified but loopification will
514 -- not care.
515
516 -- A function closure pointer may be tagged, so we
517 -- must take it into account when accessing the free variables.
518 bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
519 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
520
521 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
522 load_fvs node lf_info = mapM_ (\ (reg, off) ->
523 do dflags <- getDynFlags
524 let tag = lfDynTag dflags lf_info
525 emit $ mkTaggedObjectLoad dflags reg node off tag)
526
527 -----------------------------------------
528 -- The "slow entry" code for a function. This entry point takes its
529 -- arguments on the stack. It loads the arguments into registers
530 -- according to the calling convention, and jumps to the function's
531 -- normal entry point. The function's closure is assumed to be in
532 -- R1/node.
533 --
534 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
535
536 mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
537 -- If this function doesn't have a specialised ArgDescr, we need
538 -- to generate the function's arg bitmap and slow-entry code.
539 -- Here, we emit the slow-entry code.
540 mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
541 | Just (_, ArgGen _) <- closureFunInfo cl_info
542 = do dflags <- getDynFlags
543 let node = idToReg dflags (NonVoid bndr)
544 slow_lbl = closureSlowEntryLabel cl_info
545 fast_lbl = closureLocalEntryLabel dflags cl_info
546 -- mkDirectJump does not clobber `Node' containing function closure
547 jump = mkJump dflags NativeNodeCall
548 (mkLblExpr fast_lbl)
549 (map (CmmReg . CmmLocal) (node : arg_regs))
550 (initUpdFrameOff dflags)
551 tscope <- getTickScope
552 emitProcWithConvention Slow Nothing slow_lbl
553 (node : arg_regs) (jump, tscope)
554 | otherwise = return ()
555
556 -----------------------------------------
557 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
558 -> LocalReg -> Int -> StgExpr -> FCode ()
559 thunkCode cl_info fv_details _cc node arity body
560 = do { dflags <- getDynFlags
561 ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
562 node' = if node_points then Just node else Nothing
563 ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
564
565 -- Heap overflow check
566 ; entryHeapCheck cl_info node' arity [] $ do
567 { -- Overwrite with black hole if necessary
568 -- but *after* the heap-overflow check
569 ; tickyEnterThunk cl_info
570 ; when (blackHoleOnEntry cl_info && node_points)
571 (blackHoleIt node)
572
573 -- Push update frame
574 ; setupUpdate cl_info node $
575 -- We only enter cc after setting up update so
576 -- that cc of enclosing scope will be recorded
577 -- in update frame CAF/DICT functions will be
578 -- subsumed by this enclosing cc
579 do { tickyEnterThunk cl_info
580 ; enterCostCentreThunk (CmmReg nodeReg)
581 ; let lf_info = closureLFInfo cl_info
582 ; fv_bindings <- mapM bind_fv fv_details
583 ; load_fvs node lf_info fv_bindings
584 ; void $ cgExpr body }}}
585
586
587 ------------------------------------------------------------------------
588 -- Update and black-hole wrappers
589 ------------------------------------------------------------------------
590
591 blackHoleIt :: LocalReg -> FCode ()
592 -- Only called for closures with no args
593 -- Node points to the closure
594 blackHoleIt node_reg
595 = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
596
597 emitBlackHoleCode :: CmmExpr -> FCode ()
598 emitBlackHoleCode node = do
599 dflags <- getDynFlags
600
601 -- Eager blackholing is normally disabled, but can be turned on with
602 -- -feager-blackholing. When it is on, we replace the info pointer
603 -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
604
605 -- If we wanted to do eager blackholing with slop filling, we'd need
606 -- to do it at the *end* of a basic block, otherwise we overwrite
607 -- the free variables in the thunk that we still need. We have a
608 -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
609 -- [6/2004]
610 --
611 -- Previously, eager blackholing was enabled when ticky-ticky was
612 -- on. But it didn't work, and it wasn't strictly necessary to bring
613 -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
614 -- unconditionally disabled. -- krc 1/2007
615
616 -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
617 -- because emitBlackHoleCode is called from CmmParse.
618
619 let eager_blackholing = not (gopt Opt_SccProfilingOn dflags)
620 && gopt Opt_EagerBlackHoling dflags
621 -- Profiling needs slop filling (to support LDV
622 -- profiling), so currently eager blackholing doesn't
623 -- work with profiling.
624
625 when eager_blackholing $ do
626 emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))
627 (CmmReg (CmmGlobal CurrentTSO))
628 emitPrimCall [] MO_WriteBarrier []
629 emitStore node (CmmReg (CmmGlobal EagerBlackholeInfo))
630
631 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
632 -- Nota Bene: this function does not change Node (even if it's a CAF),
633 -- so that the cost centre in the original closure can still be
634 -- extracted by a subsequent enterCostCentre
635 setupUpdate closure_info node body
636 | not (lfUpdatable (closureLFInfo closure_info))
637 = body
638
639 | not (isStaticClosure closure_info)
640 = if not (closureUpdReqd closure_info)
641 then do tickyUpdateFrameOmitted; body
642 else do
643 tickyPushUpdateFrame
644 dflags <- getDynFlags
645 let
646 bh = blackHoleOnEntry closure_info &&
647 not (gopt Opt_SccProfilingOn dflags) &&
648 gopt Opt_EagerBlackHoling dflags
649
650 lbl | bh = mkBHUpdInfoLabel
651 | otherwise = mkUpdInfoLabel
652
653 pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
654
655 | otherwise -- A static closure
656 = do { tickyUpdateBhCaf closure_info
657
658 ; if closureUpdReqd closure_info
659 then do -- Blackhole the (updatable) CAF:
660 { upd_closure <- link_caf node True
661 ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
662 else do {tickyUpdateFrameOmitted; body}
663 }
664
665 -----------------------------------------------------------------------------
666 -- Setting up update frames
667
668 -- Push the update frame on the stack in the Entry area,
669 -- leaving room for the return address that is already
670 -- at the old end of the area.
671 --
672 pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
673 pushUpdateFrame lbl updatee body
674 = do
675 updfr <- getUpdFrameOff
676 dflags <- getDynFlags
677 let
678 hdr = fixedHdrSize dflags
679 frame = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr dflags
680 --
681 emitUpdateFrame dflags (CmmStackSlot Old frame) lbl updatee
682 withUpdFrameOff frame body
683
684 emitUpdateFrame :: DynFlags -> CmmExpr -> CLabel -> CmmExpr -> FCode ()
685 emitUpdateFrame dflags frame lbl updatee = do
686 let
687 hdr = fixedHdrSize dflags
688 off_updatee = hdr + oFFSET_StgUpdateFrame_updatee dflags
689 --
690 emitStore frame (mkLblExpr lbl)
691 emitStore (cmmOffset dflags frame off_updatee) updatee
692 initUpdFrameProf frame
693
694 -----------------------------------------------------------------------------
695 -- Entering a CAF
696 --
697 -- See Note [CAF management] in rts/sm/Storage.c
698
699 link_caf :: LocalReg -- pointer to the closure
700 -> Bool -- True <=> updatable, False <=> single-entry
701 -> FCode CmmExpr -- Returns amode for closure to be updated
702 -- This function returns the address of the black hole, so it can be
703 -- updated with the new value when available.
704 link_caf node _is_upd = do
705 { dflags <- getDynFlags
706 -- Call the RTS function newCAF, returning the newly-allocated
707 -- blackhole indirection closure
708 ; let newCAF_lbl = mkForeignLabel (fsLit "newCAF") Nothing
709 ForeignLabelInExternalPackage IsFunction
710 ; bh <- newTemp (bWord dflags)
711 ; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
712 [ (CmmReg (CmmGlobal BaseReg), AddrHint),
713 (CmmReg (CmmLocal node), AddrHint) ]
714 False
715
716 -- see Note [atomic CAF entry] in rts/sm/Storage.c
717 ; updfr <- getUpdFrameOff
718 ; let target = entryCode dflags (closureInfoPtr dflags (CmmReg (CmmLocal node)))
719 ; emit =<< mkCmmIfThen
720 (cmmEqWord dflags (CmmReg (CmmLocal bh)) (zeroExpr dflags))
721 -- re-enter the CAF
722 (mkJump dflags NativeNodeCall target [] updfr)
723
724 ; return (CmmReg (CmmLocal bh)) }
725
726 ------------------------------------------------------------------------
727 -- Profiling
728 ------------------------------------------------------------------------
729
730 -- For "global" data constructors the description is simply occurrence
731 -- name of the data constructor itself. Otherwise it is determined by
732 -- @closureDescription@ from the let binding information.
733
734 closureDescription :: DynFlags
735 -> Module -- Module
736 -> Name -- Id of closure binding
737 -> String
738 -- Not called for StgRhsCon which have global info tables built in
739 -- CgConTbls.hs with a description generated from the data constructor
740 closureDescription dflags mod_name name
741 = showSDocDump dflags (char '<' <>
742 (if isExternalName name
743 then ppr name -- ppr will include the module name prefix
744 else pprModule mod_name <> char '.' <> ppr name) <>
745 char '>')
746 -- showSDocDump, because we want to see the unique on the Name.