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