4631b2dc14b15eba1feb6a017ae0a9353e9751cd
[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(..) )
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 Data.Maybe
54 import Control.Monad
55
56 ------------------------------------------------------------------------
57 -- Top-level bindings
58 ------------------------------------------------------------------------
59
60 -- For closures bound at top level, allocate in static space.
61 -- They should have no free variables.
62
63 cgTopRhsClosure :: DynFlags
64 -> RecFlag -- member of a recursive group?
65 -> Id
66 -> CostCentreStack -- Optional cost centre annotation
67 -> StgBinderInfo
68 -> UpdateFlag
69 -> [Id] -- Args
70 -> StgExpr
71 -> (CgIdInfo, FCode ())
72
73 cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
74 let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id)
75 cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label)
76 lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args
77 in (cg_id_info, gen_code dflags lf_info closure_label)
78 where
79 -- special case for a indirection (f = g). We create an IND_STATIC
80 -- closure pointing directly to the indirectee. This is exactly
81 -- what the CAF will eventually evaluate to anyway, we're just
82 -- shortcutting the whole process, and generating a lot less code
83 -- (#7308)
84 --
85 -- Note: we omit the optimisation when this binding is part of a
86 -- recursive group, because the optimisation would inhibit the black
87 -- hole detection from working in that case. Test
88 -- concurrent/should_run/4030 fails, for instance.
89 --
90 gen_code dflags _ closure_label
91 | StgApp f [] <- body, null args, isNonRec rec
92 = do
93 cg_info <- getCgIdInfo f
94 let closure_rep = mkStaticClosureFields dflags
95 indStaticInfoTable ccs MayHaveCafRefs
96 [unLit (idInfoToAmode cg_info)]
97 emitDataLits closure_label closure_rep
98 return ()
99
100 gen_code dflags lf_info closure_label
101 = do { -- LAY OUT THE OBJECT
102 let name = idName id
103 ; mod_name <- getModuleName
104 ; let descr = closureDescription dflags mod_name name
105 closure_info = mkClosureInfo dflags True id lf_info 0 0 descr
106
107 caffy = idCafInfo id
108 info_tbl = mkCmmInfo closure_info -- XXX short-cut
109 closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy []
110
111 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
112 ; emitDataLits closure_label closure_rep
113 ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
114 (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info)
115 (addIdReps [])
116 -- Don't drop the non-void args until the closure info has been made
117 ; forkClosureBody (closureCodeBody True id closure_info ccs
118 (nonVoidIds args) (length args) body fv_details)
119
120 ; return () }
121
122 unLit (CmmLit l) = l
123 unLit _ = panic "unLit"
124
125 ------------------------------------------------------------------------
126 -- Non-top-level bindings
127 ------------------------------------------------------------------------
128
129 cgBind :: StgBinding -> FCode ()
130 cgBind (StgNonRec name rhs)
131 = do { (info, fcode) <- cgRhs name rhs
132 ; addBindC info
133 ; init <- fcode
134 ; emit init }
135 -- init cannot be used in body, so slightly better to sink it eagerly
136
137 cgBind (StgRec pairs)
138 = do { r <- sequence $ unzipWith cgRhs pairs
139 ; let (id_infos, fcodes) = unzip r
140 ; addBindsC id_infos
141 ; (inits, body) <- getCodeR $ sequence fcodes
142 ; emit (catAGraphs inits <*> body) }
143
144 {- Note [cgBind rec]
145
146 Recursive let-bindings are tricky.
147 Consider the following pseudocode:
148
149 let x = \_ -> ... y ...
150 y = \_ -> ... z ...
151 z = \_ -> ... x ...
152 in ...
153
154 For each binding, we need to allocate a closure, and each closure must
155 capture the address of the other closures.
156 We want to generate the following C-- code:
157 // Initialization Code
158 x = hp - 24; // heap address of x's closure
159 y = hp - 40; // heap address of x's closure
160 z = hp - 64; // heap address of x's closure
161 // allocate and initialize x
162 m[hp-8] = ...
163 m[hp-16] = y // the closure for x captures y
164 m[hp-24] = x_info;
165 // allocate and initialize y
166 m[hp-32] = z; // the closure for y captures z
167 m[hp-40] = y_info;
168 // allocate and initialize z
169 ...
170
171 For each closure, we must generate not only the code to allocate and
172 initialize the closure itself, but also some initialization Code that
173 sets a variable holding the closure pointer.
174
175 We could generate a pair of the (init code, body code), but since
176 the bindings are recursive we also have to initialise the
177 environment with the CgIdInfo for all the bindings before compiling
178 anything. So we do this in 3 stages:
179
180 1. collect all the CgIdInfos and initialise the environment
181 2. compile each binding into (init, body) code
182 3. emit all the inits, and then all the bodies
183
184 We'd rather not have separate functions to do steps 1 and 2 for
185 each binding, since in pratice they share a lot of code. So we
186 have just one function, cgRhs, that returns a pair of the CgIdInfo
187 for step 1, and a monadic computation to generate the code in step
188 2.
189
190 The alternative to separating things in this way is to use a
191 fixpoint. That's what we used to do, but it introduces a
192 maintenance nightmare because there is a subtle dependency on not
193 being too strict everywhere. Doing things this way means that the
194 FCode monad can be strict, for example.
195 -}
196
197 cgRhs :: Id
198 -> StgRhs
199 -> FCode (
200 CgIdInfo -- The info for this binding
201 , FCode CmmAGraph -- A computation which will generate the
202 -- code for the binding, and return an
203 -- assignent of the form "x = Hp - n"
204 -- (see above)
205 )
206
207 cgRhs id (StgRhsCon cc con args)
208 = withNewTickyCounterThunk False (idName id) $ -- False for "not static"
209 buildDynCon id True cc con args
210
211 {- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -}
212 cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
213 = do dflags <- getDynFlags
214 mkRhsClosure dflags name 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 (StgCase (StgApp scrutinee [{-no args-}])
268 _ _ _ _ -- ignore uniq, etc.
269 (AlgAlt _)
270 [(DataAlt _, params, _use_mask,
271 (StgApp selectee [{-no args-}]))])
272 | the_fv == scrutinee -- Scrutinee is the only free variable
273 && isJust maybe_offset -- Selectee is a component of the tuple
274 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE dflags -- Offset is small enough
275 = -- NOT TRUE: ASSERT(is_single_constructor)
276 -- The simplifier may have statically determined that the single alternative
277 -- is the only possible case and eliminated the others, even if there are
278 -- other constructors in the datatype. It's still ok to make a selector
279 -- thunk in this case, because we *know* which constructor the scrutinee
280 -- will evaluate to.
281 --
282 -- srt is discarded; it must be empty
283 cgRhsStdThunk bndr lf_info [StgVarArg the_fv]
284 where
285 lf_info = mkSelectorLFInfo bndr offset_into_int
286 (isUpdatable upd_flag)
287 (_, _, params_w_offsets) = mkVirtConstrOffsets dflags (addIdReps params)
288 -- Just want the layout
289 maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
290 Just the_offset = maybe_offset
291 offset_into_int = bytesToWordsRoundUp dflags the_offset
292 - fixedHdrSizeW dflags
293
294 ---------- Note [Ap thunks] ------------------
295 mkRhsClosure dflags bndr _cc _bi
296 fvs
297 upd_flag
298 [] -- No args; a thunk
299 (StgApp fun_id args)
300
301 | args `lengthIs` (arity-1)
302 && all (isGcPtrRep . idPrimRep . unsafe_stripNV) fvs
303 && isUpdatable upd_flag
304 && arity <= mAX_SPEC_AP_SIZE dflags
305 && not (gopt Opt_SccProfilingOn dflags)
306 -- not when profiling: we don't want to
307 -- lose information about this particular
308 -- thunk (e.g. its type) (#949)
309
310 -- Ha! an Ap thunk
311 = cgRhsStdThunk bndr lf_info payload
312
313 where
314 lf_info = mkApLFInfo bndr upd_flag arity
315 -- the payload has to be in the correct order, hence we can't
316 -- just use the fvs.
317 payload = StgVarArg fun_id : args
318 arity = length fvs
319
320 ---------- Default case ------------------
321 mkRhsClosure dflags bndr cc _ fvs upd_flag args body
322 = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args
323 ; (id_info, reg) <- rhsIdInfo bndr lf_info
324 ; return (id_info, gen_code lf_info reg) }
325 where
326 gen_code lf_info reg
327 = do { -- LAY OUT THE OBJECT
328 -- If the binder is itself a free variable, then don't store
329 -- it in the closure. Instead, just bind it to Node on entry.
330 -- NB we can be sure that Node will point to it, because we
331 -- haven't told mkClosureLFInfo about this; so if the binder
332 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
333 -- stored in the closure itself, so it will make sure that
334 -- Node points to it...
335 ; let
336 is_elem = isIn "cgRhsClosure"
337 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
338 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
339 | otherwise = fvs
340
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 (tot_wds, ptr_wds, fv_details)
349 = mkVirtHeapOffsets dflags (isLFThunk lf_info)
350 (addIdReps (map unsafe_stripNV 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 = curCCS; blame_cc = curCCS
366 ; emit (mkComment $ mkFastString "calling allocDynClosure")
367 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
368 ; let info_tbl = mkCmmInfo closure_info
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 False (idName bndr) $ -- False for "not static"
389 do
390 { -- LAY OUT THE OBJECT
391 mod_name <- getModuleName
392 ; dflags <- getDynFlags
393 ; let (tot_wds, ptr_wds, payload_w_offsets)
394 = mkVirtHeapOffsets dflags (isLFThunk lf_info) (addArgReps payload)
395
396 descr = closureDescription dflags mod_name (idName bndr)
397 closure_info = mkClosureInfo dflags False -- Not static
398 bndr lf_info tot_wds ptr_wds
399 descr
400
401 -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
402 ; let use_cc = curCCS; blame_cc = curCCS
403
404 ; tickyEnterStdThunk closure_info
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 The Macros for GrAnSim are produced at the beginning of the
453 argSatisfactionCheck (by calling fetchAndReschedule).
454 There info if Node points to closure is available. -- HWL -}
455
456 closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
457 | arity == 0 -- No args i.e. thunk
458 = withNewTickyCounterThunk (isStaticClosure cl_info) (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 (closureName cl_info) args $ do {
468
469 ; let
470 lf_info = closureLFInfo cl_info
471 info_tbl = mkCmmInfo cl_info
472
473 -- Emit the main entry code
474 ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
475 \(_offset, node, arg_regs) -> do
476 -- Emit slow-entry code (for entering a closure through a PAP)
477 { mkSlowEntryCode bndr cl_info arg_regs
478 ; dflags <- getDynFlags
479 ; let node_points = nodeMustPointToIt dflags lf_info
480 node' = if node_points then Just node else Nothing
481 ; loop_header_id <- newLabelC
482 -- Extend reader monad with information that
483 -- self-recursive tail calls can be optimized into local
484 -- jumps. See Note [Self-recursive tail calls] in StgCmmExpr.
485 ; withSelfLoop (bndr, loop_header_id, arg_regs) $ do
486 {
487 -- Main payload
488 ; entryHeapCheck cl_info node' arity arg_regs $ do
489 { -- emit LDV code when profiling
490 when node_points (ldvEnterClosure cl_info (CmmLocal node))
491 -- ticky after heap check to avoid double counting
492 ; tickyEnterFun cl_info
493 ; enterCostCentreFun cc
494 (CmmMachOp (mo_wordSub dflags)
495 [ CmmReg (CmmLocal node) -- See [NodeReg clobbered with loopification]
496 , mkIntExpr dflags (funTag dflags cl_info) ])
497 ; fv_bindings <- mapM bind_fv fv_details
498 -- Load free vars out of closure *after*
499 -- heap check, to reduce live vars over check
500 ; when node_points $ load_fvs node lf_info fv_bindings
501 ; void $ cgExpr body
502 }}}
503
504 }
505
506 -- Note [NodeReg clobbered with loopification]
507 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
508 --
509 -- Previously we used to pass nodeReg (aka R1) here. With profiling, upon
510 -- entering a closure, enterFunCCS was called with R1 passed to it. But since R1
511 -- may get clobbered inside the body of a closure, and since a self-recursive
512 -- tail call does not restore R1, a subsequent call to enterFunCCS received a
513 -- possibly bogus value from R1. The solution is to not pass nodeReg (aka R1) to
514 -- enterFunCCS. Instead, we pass node, the callee-saved temporary that stores
515 -- the original value of R1. This way R1 may get modified but loopification will
516 -- not care.
517
518 -- A function closure pointer may be tagged, so we
519 -- must take it into account when accessing the free variables.
520 bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
521 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
522
523 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
524 load_fvs node lf_info = mapM_ (\ (reg, off) ->
525 do dflags <- getDynFlags
526 let tag = lfDynTag dflags lf_info
527 emit $ mkTaggedObjectLoad dflags reg node off tag)
528
529 -----------------------------------------
530 -- The "slow entry" code for a function. This entry point takes its
531 -- arguments on the stack. It loads the arguments into registers
532 -- according to the calling convention, and jumps to the function's
533 -- normal entry point. The function's closure is assumed to be in
534 -- R1/node.
535 --
536 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
537
538 mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
539 -- If this function doesn't have a specialised ArgDescr, we need
540 -- to generate the function's arg bitmap and slow-entry code.
541 -- Here, we emit the slow-entry code.
542 mkSlowEntryCode bndr cl_info arg_regs -- function closure is already in `Node'
543 | Just (_, ArgGen _) <- closureFunInfo cl_info
544 = do dflags <- getDynFlags
545 let node = idToReg dflags (NonVoid bndr)
546 slow_lbl = closureSlowEntryLabel cl_info
547 fast_lbl = closureLocalEntryLabel dflags cl_info
548 -- mkDirectJump does not clobber `Node' containing function closure
549 jump = mkJump dflags NativeNodeCall
550 (mkLblExpr fast_lbl)
551 (map (CmmReg . CmmLocal) (node : arg_regs))
552 (initUpdFrameOff dflags)
553 emitProcWithConvention Slow Nothing slow_lbl (node : arg_regs) jump
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.lhs 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.