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