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