1 -----------------------------------------------------------------------------
3 -- Stg to C-- code generation: bindings
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
16 #include "HsVersions.h"
32 import CoreSyn ( AltCon(..) )
40 import Monad (foldM, liftM)
53 ------------------------------------------------------------------------
55 ------------------------------------------------------------------------
57 -- For closures bound at top level, allocate in static space.
58 -- They should have no free variables.
61 -> CostCentreStack -- Optional cost centre annotation
69 cgTopRhsClosure id ccs _ upd_flag srt args body = do
70 { -- LAY OUT THE OBJECT
72 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
73 ; srt_info <- getSRTInfo srt
74 ; mod_name <- getModuleName
75 ; let descr = closureDescription mod_name name
76 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
77 closure_label = mkLocalClosureLabel name (idCafInfo id)
78 cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
79 closure_rep = mkStaticClosureFields closure_info ccs True []
81 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
82 ; emitDataLits closure_label closure_rep
83 ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
84 (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
86 -- Don't drop the non-void args until the closure info has been made
87 ; forkClosureBody (closureCodeBody True id closure_info ccs
88 (nonVoidIds args) (length args) body fv_details)
90 ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
93 ------------------------------------------------------------------------
94 -- Non-top-level bindings
95 ------------------------------------------------------------------------
97 cgBind :: StgBinding -> FCode ()
98 cgBind (StgNonRec name rhs)
99 = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
100 ; addBindC (cg_id info) info
101 ; emit (init <*> body) }
103 cgBind (StgRec pairs)
104 = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
105 do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
106 ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
107 ; addBindsC new_binds
108 ; emit (catAGraphs inits <*> body) }
110 {- Recursive let-bindings are tricky.
111 Consider the following pseudocode:
112 let x = \_ -> ... y ...
116 For each binding, we need to allocate a closure, and each closure must
117 capture the address of the other closures.
118 We want to generate the following C-- code:
119 // Initialization Code
120 x = hp - 24; // heap address of x's closure
121 y = hp - 40; // heap address of x's closure
122 z = hp - 64; // heap address of x's closure
123 // allocate and initialize x
125 m[hp-16] = y // the closure for x captures y
127 // allocate and initialize y
128 m[hp-32] = z; // the closure for y captures z
130 // allocate and initialize z
133 For each closure, we must generate not only the code to allocate and
134 initialize the closure itself, but also some Initialization Code that
135 sets a variable holding the closure pointer.
136 The complication here is that we don't know the heap offsets a priori,
137 which has two consequences:
138 1. we need a fixpoint
139 2. we can't trivially separate the Initialization Code from the
140 code that compiles the right-hand-sides
142 Note: We don't need this complication with let-no-escapes, because
143 in that case, the names are bound to labels in the environment,
144 and we don't need to emit any code to witness that binding.
148 cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
149 -- The Id is passed along so a binding can be set up
150 -- The returned values are the binding for the environment
151 -- and the Initialization Code that witnesses the binding
153 cgRhs name (StgRhsCon maybe_cc con args)
154 = buildDynCon name maybe_cc con args
156 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
157 = pprTrace "cgRhs closure" (ppr name <+> ppr args) $
158 mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
160 ------------------------------------------------------------------------
161 -- Non-constructor right hand sides
162 ------------------------------------------------------------------------
164 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
165 -> [NonVoid Id] -- Free vars
169 -> FCode (CgIdInfo, CmmAGraph)
171 {- mkRhsClosure looks for two special forms of the right-hand side:
175 If neither happens, it just calls mkClosureLFInfo. You might think
176 that mkClosureLFInfo should do all this, but it seems wrong for the
177 latter to look at the structure of an expression
181 We look at the body of the closure to see if it's a selector---turgid,
182 but nothing deep. We are looking for a closure of {\em exactly} the
185 ... = [the_fv] \ u [] ->
187 con a_1 ... a_n -> a_i
191 A more generic AP thunk of the form
193 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
195 A set of these is compiled statically into the RTS, so we just use
196 those. We could extend the idea to thunks where some of the x_i are
197 global ids (and hence not free variables), but this would entail
198 generating a larger thunk. It might be an option for non-optimising
201 We only generate an Ap thunk if all the free variables are pointers,
202 for semi-obvious reasons.
206 ---------- Note [Selectors] ------------------
207 mkRhsClosure bndr cc bi
208 [NonVoid the_fv] -- Just one free var
209 upd_flag -- Updatable thunk
212 body@(StgCase (StgApp scrutinee [{-no args-}])
213 _ _ _ _ -- ignore uniq, etc.
215 [(DataAlt con, params, _use_mask,
216 (StgApp selectee [{-no args-}]))])
217 | the_fv == scrutinee -- Scrutinee is the only free variable
218 && maybeToBool maybe_offset -- Selectee is a component of the tuple
219 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
220 = -- NOT TRUE: ASSERT(is_single_constructor)
221 -- The simplifier may have statically determined that the single alternative
222 -- is the only possible case and eliminated the others, even if there are
223 -- other constructors in the datatype. It's still ok to make a selector
224 -- thunk in this case, because we *know* which constructor the scrutinee
227 -- srt is discarded; it must be empty
228 cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
230 lf_info = mkSelectorLFInfo bndr offset_into_int
231 (isUpdatable upd_flag)
232 (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
233 -- Just want the layout
234 maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
235 Just the_offset = maybe_offset
236 offset_into_int = the_offset - fixedHdrSize
238 ---------- Note [Ap thunks] ------------------
239 mkRhsClosure bndr cc bi
243 [] -- No args; a thunk
244 body@(StgApp fun_id args)
246 | args `lengthIs` (arity-1)
247 && all isFollowableArg (map (idCgRep . stripNV) fvs)
248 && isUpdatable upd_flag
249 && arity <= mAX_SPEC_AP_SIZE
252 = cgStdThunk bndr cc bi body lf_info payload
254 lf_info = mkApLFInfo bndr upd_flag arity
255 -- the payload has to be in the correct order, hence we can't
257 payload = StgVarArg fun_id : args
260 ---------- Default case ------------------
261 mkRhsClosure bndr cc _ fvs upd_flag srt args body
262 = do { -- LAY OUT THE OBJECT
263 -- If the binder is itself a free variable, then don't store
264 -- it in the closure. Instead, just bind it to Node on entry.
265 -- NB we can be sure that Node will point to it, because we
266 -- haven't told mkClosureLFInfo about this; so if the binder
267 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
268 -- stored in the closure itself, so it will make sure that
269 -- Node points to it...
271 is_elem = isIn "cgRhsClosure"
272 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
273 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
277 -- MAKE CLOSURE INFO FOR THIS CLOSURE
278 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
279 ; mod_name <- getModuleName
280 ; c_srt <- getSRTInfo srt
281 ; let name = idName bndr
282 descr = closureDescription mod_name name
283 fv_details :: [(NonVoid Id, VirtualHpOffset)]
284 (tot_wds, ptr_wds, fv_details)
285 = mkVirtHeapOffsets (isLFThunk lf_info)
286 (addIdReps (map stripNV reduced_fvs))
287 closure_info = mkClosureInfo False -- Not static
288 bndr lf_info tot_wds ptr_wds
291 -- BUILD ITS INFO TABLE AND CODE
293 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
294 -- (b) ignore Sequel from context; use empty Sequel
295 -- And compile the body
296 closureCodeBody False bndr closure_info cc (nonVoidIds args)
297 (length args) body fv_details
300 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
301 ; emit (mkComment $ mkFastString "calling allocDynClosure")
302 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
303 ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
304 (map toVarArg fv_details)
307 ; return $ (regIdInfo bndr lf_info tmp, init) }
309 -- Use with care; if used inappropriately, it could break invariants.
310 stripNV :: NonVoid a -> a
311 stripNV (NonVoid a) = a
313 -------------------------
316 -> CostCentreStack -- Optional cost centre annotation
317 -> StgBinderInfo -- XXX: not used??
320 -> [StgArg] -- payload
321 -> FCode (CgIdInfo, CmmAGraph)
323 cgStdThunk bndr cc _bndr_info body lf_info payload
324 = do -- AHA! A STANDARD-FORM THUNK
325 { -- LAY OUT THE OBJECT
326 mod_name <- getModuleName
327 ; let (tot_wds, ptr_wds, payload_w_offsets)
328 = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
330 descr = closureDescription mod_name (idName bndr)
331 closure_info = mkClosureInfo False -- Not static
332 bndr lf_info tot_wds ptr_wds
333 NoC_SRT -- No SRT for a std-form closure
336 ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
339 ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
342 ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
344 mkClosureLFInfo :: Id -- The binder
345 -> TopLevelFlag -- True of top level
346 -> [NonVoid Id] -- Free vars
347 -> UpdateFlag -- Update flag
349 -> FCode LambdaFormInfo
350 mkClosureLFInfo bndr top fvs upd_flag args
351 | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
352 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
353 ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
356 ------------------------------------------------------------------------
357 -- The code for closures}
358 ------------------------------------------------------------------------
360 closureCodeBody :: Bool -- whether this is a top-level binding
361 -> Id -- the closure's name
362 -> ClosureInfo -- Lots of information about this closure
363 -> CostCentreStack -- Optional cost centre attached to closure
364 -> [NonVoid Id] -- incoming args to the closure
365 -> Int -- arity, including void args
367 -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
370 {- There are two main cases for the code for closures.
372 * If there are *no arguments*, then the closure is a thunk, and not in
373 normal form. So it should set up an update frame (if it is
374 shared). NB: Thunks cannot have a primitive type!
376 * If there is *at least one* argument, then this closure is in
377 normal form, so there is no need to set up an update frame.
379 The Macros for GrAnSim are produced at the beginning of the
380 argSatisfactionCheck (by calling fetchAndReschedule).
381 There info if Node points to closure is available. -- HWL -}
383 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
384 | length args == 0 -- No args i.e. thunk
385 = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
386 (\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
388 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
389 = ASSERT( length args > 0 )
390 do { -- Allocate the global ticky counter,
391 -- and establish the ticky-counter
392 -- label for this block
393 let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
394 ; emitTickyCounter cl_info (map stripNV args)
395 ; setTickyCtrLabel ticky_ctr_lbl $ do
397 -- Emit the main entry code
398 ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
399 -- Emit the slow-entry code (for entering a closure through a PAP)
400 { mkSlowEntryCode cl_info arg_regs
402 ; let lf_info = closureLFInfo cl_info
403 node_points = nodeMustPointToIt lf_info
404 ; tickyEnterFun cl_info
405 ; whenC node_points (ldvEnterClosure cl_info)
406 ; granYield arg_regs node_points
409 ; entryHeapCheck node arity arg_regs $ do
410 { enterCostCentre cl_info cc body
411 ; fv_bindings <- mapM bind_fv fv_details
412 ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
413 ; cgExpr body }} -- heap check, to reduce live vars over check
417 -- A function closure pointer may be tagged, so we
418 -- must take it into account when accessing the free variables.
419 bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
420 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
422 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
423 load_fvs node lf_info = mapCs (\ (reg, off) ->
424 pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag)
425 where tag = lfDynTag lf_info
427 -----------------------------------------
428 -- The "slow entry" code for a function. This entry point takes its
429 -- arguments on the stack. It loads the arguments into registers
430 -- according to the calling convention, and jumps to the function's
431 -- normal entry point. The function's closure is assumed to be in
434 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
436 mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
437 -- If this function doesn't have a specialised ArgDescr, we need
438 -- to generate the function's arg bitmap and slow-entry code.
439 -- Here, we emit the slow-entry code.
440 mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
441 | Just (_, ArgGen _) <- closureFunInfo cl_info
442 = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
444 | otherwise = return ()
446 caf_refs = clHasCafRefs cl_info
447 name = closureName cl_info
448 slow_lbl = mkSlowEntryLabel name caf_refs
449 fast_lbl = enterLocalIdLabel name caf_refs
450 jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
452 mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
454 -----------------------------------------
455 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
456 LocalReg -> Int -> StgExpr -> FCode ()
457 thunkCode cl_info fv_details cc node arity body
458 = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
459 ; tickyEnterThunk cl_info
460 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
461 ; granThunk node_points
463 -- Heap overflow check
464 ; entryHeapCheck node arity [] $ do
465 { -- Overwrite with black hole if necessary
466 -- but *after* the heap-overflow check
467 whenC (blackHoleOnEntry cl_info && node_points)
468 (blackHoleIt cl_info)
471 ; setupUpdate cl_info node $
472 -- We only enter cc after setting up update so
473 -- that cc of enclosing scope will be recorded
474 -- in update frame CAF/DICT functions will be
475 -- subsumed by this enclosing cc
476 do { enterCostCentre cl_info cc body
477 ; let lf_info = closureLFInfo cl_info
478 ; fv_bindings <- mapM bind_fv fv_details
479 ; load_fvs node lf_info fv_bindings
483 ------------------------------------------------------------------------
484 -- Update and black-hole wrappers
485 ------------------------------------------------------------------------
487 blackHoleIt :: ClosureInfo -> FCode ()
488 -- Only called for closures with no args
489 -- Node points to the closure
490 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
492 emitBlackHoleCode :: Bool -> FCode ()
493 emitBlackHoleCode is_single_entry
494 | eager_blackholing = do
495 tickyBlackHole (not is_single_entry)
496 emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
500 bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
501 | otherwise = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
503 -- If we wanted to do eager blackholing with slop filling,
504 -- we'd need to do it at the *end* of a basic block, otherwise
505 -- we overwrite the free variables in the thunk that we still
506 -- need. We have a patch for this from Andy Cheadle, but not
507 -- incorporated yet. --SDM [6/2004]
509 -- Profiling needs slop filling (to support LDV profiling), so
510 -- currently eager blackholing doesn't work with profiling.
512 -- Previously, eager blackholing was enabled when ticky-ticky
513 -- was on. But it didn't work, and it wasn't strictly necessary
514 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
515 -- is unconditionally disabled. -- krc 1/2007
517 eager_blackholing = False
519 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
520 -- Nota Bene: this function does not change Node (even if it's a CAF),
521 -- so that the cost centre in the original closure can still be
522 -- extracted by a subsequent enterCostCentre
523 setupUpdate closure_info node body
524 | closureReEntrant closure_info
527 | not (isStaticClosure closure_info)
528 = if closureUpdReqd closure_info
529 then do { tickyPushUpdateFrame;
530 ; pushUpdateFrame [CmmReg (CmmLocal node),
531 mkLblExpr mkUpdInfoLabel] body }
532 else do { tickyUpdateFrameOmitted; body}
534 | otherwise -- A static closure
535 = do { tickyUpdateBhCaf closure_info
537 ; if closureUpdReqd closure_info
538 then do -- Blackhole the (updatable) CAF:
539 { upd_closure <- link_caf closure_info True
540 ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
541 mkLblExpr mkUpdInfoLabel] body }
542 else do {tickyUpdateFrameOmitted; body}
545 -- Push the update frame on the stack in the Entry area,
546 -- leaving room for the return address that is already
547 -- at the old end of the area.
548 pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
549 pushUpdateFrame es body
550 = do updfr <- getUpdFrameOff
551 offset <- foldM push updfr es
552 withUpdFrameOff offset body
554 do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
556 where base = off + widthInBytes (cmmExprWidth e)
558 -----------------------------------------------------------------------------
561 -- When a CAF is first entered, it creates a black hole in the heap,
562 -- and updates itself with an indirection to this new black hole.
564 -- We update the CAF with an indirection to a newly-allocated black
565 -- hole in the heap. We also set the blocking queue on the newly
566 -- allocated black hole to be empty.
568 -- Why do we make a black hole in the heap when we enter a CAF?
570 -- - for a generational garbage collector, which needs a fast
571 -- test for whether an updatee is in an old generation or not
573 -- - for the parallel system, which can implement updates more
574 -- easily if the updatee is always in the heap. (allegedly).
576 -- When debugging, we maintain a separate CAF list so we can tell when
577 -- a CAF has been garbage collected.
579 -- newCAF must be called before the itbl ptr is overwritten, since
580 -- newCAF records the old itbl ptr in order to do CAF reverting
581 -- (which Hugs needs to do in order that combined mode works right.)
584 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
585 -- into the "newCAF" RTS procedure, which we call anyway, including
586 -- the allocation of the black-hole indirection closure.
587 -- That way, code size would fall, the CAF-handling code would
588 -- be closer together, and the compiler wouldn't need to know
589 -- about off_indirectee etc.
591 link_caf :: ClosureInfo
592 -> Bool -- True <=> updatable, False <=> single-entry
593 -> FCode LocalReg -- Returns amode for closure to be updated
594 -- To update a CAF we must allocate a black hole, link the CAF onto the
595 -- CAF list, then update the CAF to point to the fresh black hole.
596 -- This function returns the address of the black hole, so it can be
597 -- updated with the new value when available. The reason for all of this
598 -- is that we only want to update dynamic heap objects, not static ones,
599 -- so that generational GC is easier.
600 link_caf cl_info _is_upd = do
601 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
602 ; let use_cc = costCentreFrom (CmmReg nodeReg)
604 ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
607 -- Call the RTS function newCAF to add the CAF to the CafList
608 -- so that the garbage collector can find them
609 -- This must be done *before* the info table pointer is overwritten,
610 -- because the old info table ptr is needed for reversion
611 ; emitRtsCallWithVols (sLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
612 -- node is live, so save it.
614 -- Overwrite the closure with a (static) indirection
615 -- to the newly-allocated black hole
616 ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
617 mkStore (CmmReg nodeReg) ind_static_info)
621 bh_cl_info :: ClosureInfo
622 bh_cl_info = cafBlackHoleClosureInfo cl_info
624 ind_static_info :: CmmExpr
625 ind_static_info = mkLblExpr mkIndStaticInfoLabel
627 off_indirectee :: WordOff
628 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
631 ------------------------------------------------------------------------
633 ------------------------------------------------------------------------
635 -- For "global" data constructors the description is simply occurrence
636 -- name of the data constructor itself. Otherwise it is determined by
637 -- @closureDescription@ from the let binding information.
639 closureDescription :: Module -- Module
640 -> Name -- Id of closure binding
642 -- Not called for StgRhsCon which have global info tables built in
643 -- CgConTbls.lhs with a description generated from the data constructor
644 closureDescription mod_name name
645 = showSDocDump (char '<' <>
646 (if isExternalName name
647 then ppr name -- ppr will include the module name prefix
648 else pprModule mod_name <> char '.' <> ppr name) <>
650 -- showSDocDump, because we want to see the unique on the Name.