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