8adf3b088e6e18e7182ce0d83d7c9739a15d2e3c
[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 = withNewTickyCounterCon (idName id) $
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, 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 (lfUpdatable lf_info) (idName bndr) $
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
406 -- BUILD THE OBJECT
407 ; let info_tbl = mkCmmInfo closure_info
408 ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
409 use_cc blame_cc payload_w_offsets
410
411 -- RETURN
412 ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
413
414
415 mkClosureLFInfo :: DynFlags
416 -> Id -- The binder
417 -> TopLevelFlag -- True of top level
418 -> [NonVoid Id] -- Free vars
419 -> UpdateFlag -- Update flag
420 -> [Id] -- Args
421 -> LambdaFormInfo
422 mkClosureLFInfo dflags bndr top fvs upd_flag args
423 | null args =
424 mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag
425 | otherwise =
426 mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args)
427
428
429 ------------------------------------------------------------------------
430 -- The code for closures
431 ------------------------------------------------------------------------
432
433 closureCodeBody :: Bool -- whether this is a top-level binding
434 -> Id -- the closure's name
435 -> ClosureInfo -- Lots of information about this closure
436 -> CostCentreStack -- Optional cost centre attached to closure
437 -> [NonVoid Id] -- incoming args to the closure
438 -> Int -- arity, including void args
439 -> StgExpr
440 -> [(NonVoid Id, ByteOff)] -- the closure's free vars
441 -> FCode ()
442
443 {- There are two main cases for the code for closures.
444
445 * If there are *no arguments*, then the closure is a thunk, and not in
446 normal form. So it should set up an update frame (if it is
447 shared). NB: Thunks cannot have a primitive type!
448
449 * If there is *at least one* argument, then this closure is in
450 normal form, so there is no need to set up an update frame.
451 -}
452
453 closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
454 | arity == 0 -- No args i.e. thunk
455 = withNewTickyCounterThunk
456 (isStaticClosure cl_info)
457 (closureUpdReqd cl_info)
458 (closureName cl_info) $
459 emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
460 \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
461 where
462 lf_info = closureLFInfo cl_info
463 info_tbl = mkCmmInfo cl_info
464
465 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
466 = -- Note: args may be [], if all args are Void
467 withNewTickyCounterFun
468 (closureSingleEntry cl_info)
469 (closureName cl_info)
470 args $ do {
471
472 ; let
473 lf_info = closureLFInfo cl_info
474 info_tbl = mkCmmInfo cl_info
475
476 -- Emit the main entry code
477 ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
478 \(_offset, node, arg_regs) -> do
479 -- Emit slow-entry code (for entering a closure through a PAP)
480 { mkSlowEntryCode bndr cl_info arg_regs
481 ; dflags <- getDynFlags
482 ; let node_points = nodeMustPointToIt dflags lf_info
483 node' = if node_points then Just node else Nothing
484 ; loop_header_id <- newLabelC
485 -- Extend reader monad with information that
486 -- self-recursive tail calls can be optimized into local
487 -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
488 ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
489 {
490 -- Main payload
491 ; entryHeapCheck cl_info node' arity arg_regs $ do
492 { -- emit LDV code when profiling
493 when node_points (ldvEnterClosure cl_info (CmmLocal node))
494 -- ticky after heap check to avoid double counting
495 ; tickyEnterFun cl_info
496 ; enterCostCentreFun cc
497 (CmmMachOp (mo_wordSub dflags)
498 [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
499 , mkIntExpr dflags (funTag dflags cl_info) ])
500 ; fv_bindings <- mapM bind_fv fv_details
501 -- Load free vars out of closure *after*
502 -- heap check, to reduce live vars over check
503 ; when node_points $ load_fvs node lf_info fv_bindings
504 ; void $ cgExpr body
505 }}}
506
507 }
508
509 -- Note [NodeReg clobbered with loopification]
510 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
511 --
512 -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
513 -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
514 -- may get clobbered inside the body of a closure, and since a self-recursive
515 -- tail call does not restore R1, a subsequent call to enterFunCCS received a
516 -- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
517 -- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
518 -- the original value of R1. This way R1 may get modified but loopification will
519 -- not care.
520
521 -- A function closure pointer may be tagged, so we
522 -- must take it into account when accessing the free variables.
523 bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
524 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
525
526 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
527 load_fvs node lf_info = mapM_ (\ (reg, off) ->
528 do dflags <- getDynFlags
529 let tag = lfDynTag dflags lf_info
530 emit $ mkTaggedObjectLoad dflags reg node off tag)
531
532 -----------------------------------------
533 -- The "slow entry" code for a function. This entry point takes its
534 -- arguments on the stack. It loads the arguments into registers
535 -- according to the calling convention, and jumps to the function's
536 -- normal entry point. The function's closure is assumed to be in
537 -- R1/node.
538 --
539 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
540
541 mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
542 -- If this function doesn't have a specialised ArgDescr, we need
543 -- to generate the function's arg bitmap and slow-entry code.
544 -- Here, we emit the slow-entry code.
545 mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
546 | Just (_, ArgGen _) <- closureFunInfo cl_info
547 = do dflags <- getDynFlags
548 let node = idToReg dflags (NonVoid bndr)
549 slow_lbl = closureSlowEntryLabel cl_info
550 fast_lbl = closureLocalEntryLabel dflags cl_info
551 -- mkDirectJump does not clobber `Node' containing function closure
552 jump = mkJump dflags NativeNodeCall
553 (mkLblExpr fast_lbl)
554 (map (CmmReg . CmmLocal) (node : arg_regs))
555 (initUpdFrameOff dflags)
556 tscope <- getTickScope
557 emitProcWithConvention Slow Nothing slow_lbl
558 (node : arg_regs) (jump, tscope)
559 | otherwise = return ()
560
561 -----------------------------------------
562 thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
563 -> LocalReg -> Int -> StgExpr -> FCode ()
564 thunkCode cl_info fv_details _cc node arity body
565 = do { dflags <- getDynFlags
566 ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info)
567 node' = if node_points then Just node else Nothing
568 ; ldvEnterClosure cl_info (CmmLocal node) -- NB: Node always points when profiling
569
570 -- Heap overflow check
571 ; entryHeapCheck cl_info node' arity [] $ do
572 { -- Overwrite with black hole if necessary
573 -- but *after* the heap-overflow check
574 ; tickyEnterThunk cl_info
575 ; when (blackHoleOnEntry cl_info && node_points)
576 (blackHoleIt node)
577
578 -- Push update frame
579 ; setupUpdate cl_info node $
580 -- We only enter cc after setting up update so
581 -- that cc of enclosing scope will be recorded
582 -- in update frame CAF/DICT functions will be
583 -- subsumed by this enclosing cc
584 do { enterCostCentreThunk (CmmReg nodeReg)
585 ; let lf_info = closureLFInfo cl_info
586 ; fv_bindings <- mapM bind_fv fv_details
587 ; load_fvs node lf_info fv_bindings
588 ; void $ cgExpr body }}}
589
590
591 ------------------------------------------------------------------------
592 -- Update and black-hole wrappers
593 ------------------------------------------------------------------------
594
595 blackHoleIt :: LocalReg -> FCode ()
596 -- Only called for closures with no args
597 -- Node points to the closure
598 blackHoleIt node_reg
599 = emitBlackHoleCode (CmmReg (CmmLocal node_reg))
600
601 emitBlackHoleCode :: CmmExpr -> FCode ()
602 emitBlackHoleCode node = do
603 dflags <- getDynFlags
604
605 -- Eager blackholing is normally disabled, but can be turned on with
606 -- -feager-blackholing. When it is on, we replace the info pointer
607 -- of the thunk with stg_EAGER_BLACKHOLE_info on entry.
608
609 -- If we wanted to do eager blackholing with slop filling, we'd need
610 -- to do it at the *end* of a basic block, otherwise we overwrite
611 -- the free variables in the thunk that we still need. We have a
612 -- patch for this from Andy Cheadle, but not incorporated yet. --SDM
613 -- [6/2004]
614 --
615 -- Previously, eager blackholing was enabled when ticky-ticky was
616 -- on. But it didn't work, and it wasn't strictly necessary to bring
617 -- back minimal ticky-ticky, so now EAGER_BLACKHOLING is
618 -- unconditionally disabled. -- krc 1/2007
619
620 -- Note the eager-blackholing check is here rather than in blackHoleOnEntry,
621 -- because emitBlackHoleCode is called from CmmParse.
622
623 let eager_blackholing = not (gopt Opt_SccProfilingOn dflags)
624 && gopt Opt_EagerBlackHoling dflags
625 -- Profiling needs slop filling (to support LDV
626 -- profiling), so currently eager blackholing doesn't
627 -- work with profiling.
628
629 when eager_blackholing $ do
630 emitStore (cmmOffsetW dflags node (fixedHdrSizeW dflags))
631 (CmmReg (CmmGlobal CurrentTSO))
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 [ (CmmReg (CmmGlobal BaseReg), 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.