1 -----------------------------------------------------------------------------
3 -- Stg to C-- code generation: bindings
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
16 #include "HsVersions.h"
31 import CoreSyn ( AltCon(..) )
50 ------------------------------------------------------------------------
52 ------------------------------------------------------------------------
54 -- For closures bound at top level, allocate in static space.
55 -- They should have no free variables.
58 -> CostCentreStack -- Optional cost centre annotation
66 cgTopRhsClosure id ccs _ upd_flag srt args body = do
67 { -- LAY OUT THE OBJECT
69 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
70 ; srt_info <- getSRTInfo srt
71 ; mod_name <- getModuleName
72 ; let descr = closureDescription mod_name name
73 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
74 closure_label = mkLocalClosureLabel name (idCafInfo id)
75 cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
76 closure_rep = mkStaticClosureFields closure_info ccs True []
78 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
79 ; emitDataLits closure_label closure_rep
80 ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
81 (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
83 -- Don't drop the non-void args until the closure info has been made
84 ; forkClosureBody (closureCodeBody True id closure_info ccs
85 (nonVoidIds args) (length args) body fv_details)
87 ; returnFC cg_id_info }
89 ------------------------------------------------------------------------
90 -- Non-top-level bindings
91 ------------------------------------------------------------------------
93 cgBind :: StgBinding -> FCode ()
94 cgBind (StgNonRec name rhs)
95 = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
96 ; addBindC (cg_id info) info
97 ; emit (init <*> body) }
100 = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
101 do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
102 ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
103 ; addBindsC new_binds
104 ; emit (catAGraphs inits <*> body) }
106 {- Recursive let-bindings are tricky.
107 Consider the following pseudocode:
108 let x = \_ -> ... y ...
112 For each binding, we need to allocate a closure, and each closure must
113 capture the address of the other closures.
114 We want to generate the following C-- code:
115 // Initialization Code
116 x = hp - 24; // heap address of x's closure
117 y = hp - 40; // heap address of x's closure
118 z = hp - 64; // heap address of x's closure
119 // allocate and initialize x
121 m[hp-16] = y // the closure for x captures y
123 // allocate and initialize y
124 m[hp-32] = z; // the closure for y captures z
126 // allocate and initialize z
129 For each closure, we must generate not only the code to allocate and
130 initialize the closure itself, but also some Initialization Code that
131 sets a variable holding the closure pointer.
132 The complication here is that we don't know the heap offsets a priori,
133 which has two consequences:
134 1. we need a fixpoint
135 2. we can't trivially separate the Initialization Code from the
136 code that compiles the right-hand-sides
138 Note: We don't need this complication with let-no-escapes, because
139 in that case, the names are bound to labels in the environment,
140 and we don't need to emit any code to witness that binding.
144 cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
145 -- The Id is passed along so a binding can be set up
146 -- The returned values are the binding for the environment
147 -- and the Initialization Code that witnesses the binding
149 cgRhs name (StgRhsCon maybe_cc con args)
150 = buildDynCon name maybe_cc con args
152 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
153 = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
155 ------------------------------------------------------------------------
156 -- Non-constructor right hand sides
157 ------------------------------------------------------------------------
159 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
160 -> [NonVoid Id] -- Free vars
164 -> FCode (CgIdInfo, CmmAGraph)
166 {- mkRhsClosure looks for two special forms of the right-hand side:
170 If neither happens, it just calls mkClosureLFInfo. You might think
171 that mkClosureLFInfo should do all this, but it seems wrong for the
172 latter to look at the structure of an expression
176 We look at the body of the closure to see if it's a selector---turgid,
177 but nothing deep. We are looking for a closure of {\em exactly} the
180 ... = [the_fv] \ u [] ->
182 con a_1 ... a_n -> a_i
186 A more generic AP thunk of the form
188 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
190 A set of these is compiled statically into the RTS, so we just use
191 those. We could extend the idea to thunks where some of the x_i are
192 global ids (and hence not free variables), but this would entail
193 generating a larger thunk. It might be an option for non-optimising
196 We only generate an Ap thunk if all the free variables are pointers,
197 for semi-obvious reasons.
201 ---------- Note [Selectors] ------------------
202 mkRhsClosure bndr cc bi
203 [NonVoid the_fv] -- Just one free var
204 upd_flag -- Updatable thunk
207 body@(StgCase (StgApp scrutinee [{-no args-}])
208 _ _ _ _ -- ignore uniq, etc.
210 [(DataAlt con, params, _use_mask,
211 (StgApp selectee [{-no args-}]))])
212 | the_fv == scrutinee -- Scrutinee is the only free variable
213 && maybeToBool maybe_offset -- Selectee is a component of the tuple
214 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
215 = -- NOT TRUE: ASSERT(is_single_constructor)
216 -- The simplifier may have statically determined that the single alternative
217 -- is the only possible case and eliminated the others, even if there are
218 -- other constructors in the datatype. It's still ok to make a selector
219 -- thunk in this case, because we *know* which constructor the scrutinee
222 -- srt is discarded; it must be empty
223 cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
225 lf_info = mkSelectorLFInfo bndr offset_into_int
226 (isUpdatable upd_flag)
227 (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
228 -- Just want the layout
229 maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
230 Just the_offset = maybe_offset
231 offset_into_int = the_offset - fixedHdrSize
233 ---------- Note [Ap thunks] ------------------
234 mkRhsClosure bndr cc bi
238 [] -- No args; a thunk
239 body@(StgApp fun_id args)
241 | args `lengthIs` (arity-1)
242 && all isFollowableArg (map (idCgRep . stripNV) fvs)
243 && isUpdatable upd_flag
244 && arity <= mAX_SPEC_AP_SIZE
247 = cgStdThunk bndr cc bi body lf_info payload
249 lf_info = mkApLFInfo bndr upd_flag arity
250 -- the payload has to be in the correct order, hence we can't
252 payload = StgVarArg fun_id : args
255 ---------- Default case ------------------
256 mkRhsClosure bndr cc _ fvs upd_flag srt args body
257 = do { -- LAY OUT THE OBJECT
258 -- If the binder is itself a free variable, then don't store
259 -- it in the closure. Instead, just bind it to Node on entry.
260 -- NB we can be sure that Node will point to it, because we
261 -- haven't told mkClosureLFInfo about this; so if the binder
262 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
263 -- stored in the closure itself, so it will make sure that
264 -- Node points to it...
266 is_elem = isIn "cgRhsClosure"
267 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
268 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
272 -- MAKE CLOSURE INFO FOR THIS CLOSURE
273 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
274 ; mod_name <- getModuleName
275 ; c_srt <- getSRTInfo srt
276 ; let name = idName bndr
277 descr = closureDescription mod_name name
278 fv_details :: [(NonVoid Id, VirtualHpOffset)]
279 (tot_wds, ptr_wds, fv_details)
280 = mkVirtHeapOffsets (isLFThunk lf_info)
281 (addIdReps (map stripNV reduced_fvs))
282 closure_info = mkClosureInfo False -- Not static
283 bndr lf_info tot_wds ptr_wds
286 -- BUILD ITS INFO TABLE AND CODE
288 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
289 -- (b) ignore Sequel from context; use empty Sequel
290 -- And compile the body
291 closureCodeBody False bndr closure_info cc (nonVoidIds args)
292 (length args) body fv_details
295 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
296 ; emit (mkComment $ mkFastString "calling allocDynClosure")
297 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
298 ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
299 (map toVarArg fv_details)
302 ; return $ (regIdInfo bndr lf_info tmp, init) }
304 -- Use with care; if used inappropriately, it could break invariants.
305 stripNV :: NonVoid a -> a
306 stripNV (NonVoid a) = a
308 -------------------------
311 -> CostCentreStack -- Optional cost centre annotation
312 -> StgBinderInfo -- XXX: not used??
315 -> [StgArg] -- payload
316 -> FCode (CgIdInfo, CmmAGraph)
318 cgStdThunk bndr cc _bndr_info body lf_info payload
319 = do -- AHA! A STANDARD-FORM THUNK
320 { -- LAY OUT THE OBJECT
321 mod_name <- getModuleName
322 ; let (tot_wds, ptr_wds, payload_w_offsets)
323 = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
325 descr = closureDescription mod_name (idName bndr)
326 closure_info = mkClosureInfo False -- Not static
327 bndr lf_info tot_wds ptr_wds
328 NoC_SRT -- No SRT for a std-form closure
331 ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
334 ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
337 ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
339 mkClosureLFInfo :: Id -- The binder
340 -> TopLevelFlag -- True of top level
341 -> [NonVoid Id] -- Free vars
342 -> UpdateFlag -- Update flag
344 -> FCode LambdaFormInfo
345 mkClosureLFInfo bndr top fvs upd_flag args
346 | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
347 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
348 ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
351 ------------------------------------------------------------------------
352 -- The code for closures}
353 ------------------------------------------------------------------------
355 closureCodeBody :: Bool -- whether this is a top-level binding
356 -> Id -- the closure's name
357 -> ClosureInfo -- Lots of information about this closure
358 -> CostCentreStack -- Optional cost centre attached to closure
359 -> [NonVoid Id] -- incoming args to the closure
360 -> Int -- arity, including void args
362 -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
365 {- There are two main cases for the code for closures.
367 * If there are *no arguments*, then the closure is a thunk, and not in
368 normal form. So it should set up an update frame (if it is
369 shared). NB: Thunks cannot have a primitive type!
371 * If there is *at least one* argument, then this closure is in
372 normal form, so there is no need to set up an update frame.
374 The Macros for GrAnSim are produced at the beginning of the
375 argSatisfactionCheck (by calling fetchAndReschedule).
376 There info if Node points to closure is available. -- HWL -}
378 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
379 | length args == 0 -- No args i.e. thunk
380 = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
381 (\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
383 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
384 = ASSERT( length args > 0 )
385 do { -- Allocate the global ticky counter,
386 -- and establish the ticky-counter
387 -- label for this block
388 let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
389 ; emitTickyCounter cl_info (map stripNV args)
390 ; setTickyCtrLabel ticky_ctr_lbl $ do
392 -- Emit the main entry code
393 ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
394 -- Emit the slow-entry code (for entering a closure through a PAP)
395 { mkSlowEntryCode cl_info arg_regs
397 ; let lf_info = closureLFInfo cl_info
398 node_points = nodeMustPointToIt lf_info
399 ; tickyEnterFun cl_info
400 ; whenC node_points (ldvEnterClosure cl_info)
401 ; granYield arg_regs node_points
404 ; entryHeapCheck (if node_points then Just node else Nothing) arity arg_regs $ do
405 { enterCostCentre cl_info cc body
406 ; fv_bindings <- mapM bind_fv fv_details
407 -- Load free vars out of closure *after*
408 ; if node_points then load_fvs node lf_info fv_bindings else return ()
409 ; cgExpr body }} -- heap check, to reduce live vars over check
413 -- A function closure pointer may be tagged, so we
414 -- must take it into account when accessing the free variables.
415 bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
416 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
418 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
419 load_fvs node lf_info = mapCs (\ (reg, off) ->
420 emit $ mkTaggedObjectLoad reg node off tag)
421 where tag = lfDynTag lf_info
423 -----------------------------------------
424 -- The "slow entry" code for a function. This entry point takes its
425 -- arguments on the stack. It loads the arguments into registers
426 -- according to the calling convention, and jumps to the function's
427 -- normal entry point. The function's closure is assumed to be in
430 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
432 mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
433 -- If this function doesn't have a specialised ArgDescr, we need
434 -- to generate the function's arg bitmap and slow-entry code.
435 -- Here, we emit the slow-entry code.
436 mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
437 | Just (_, ArgGen _) <- closureFunInfo cl_info
438 = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
440 | otherwise = return ()
442 caf_refs = clHasCafRefs cl_info
443 name = closureName cl_info
444 slow_lbl = mkSlowEntryLabel name caf_refs
445 fast_lbl = enterLocalIdLabel name caf_refs
446 jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
448 mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
450 -----------------------------------------
451 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
452 LocalReg -> Int -> StgExpr -> FCode ()
453 thunkCode cl_info fv_details cc node arity body
454 = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
455 ; tickyEnterThunk cl_info
456 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
457 ; granThunk node_points
459 -- Heap overflow check
460 ; entryHeapCheck (if node_points then Just node else Nothing) arity [] $ do
461 { -- Overwrite with black hole if necessary
462 -- but *after* the heap-overflow check
463 dflags <- getDynFlags
464 ; whenC (blackHoleOnEntry dflags cl_info && node_points)
465 (blackHoleIt cl_info)
468 ; setupUpdate cl_info node $
469 -- We only enter cc after setting up update so
470 -- that cc of enclosing scope will be recorded
471 -- in update frame CAF/DICT functions will be
472 -- subsumed by this enclosing cc
473 do { enterCostCentre cl_info cc body
474 ; let lf_info = closureLFInfo cl_info
475 ; fv_bindings <- mapM bind_fv fv_details
476 ; load_fvs node lf_info fv_bindings
480 ------------------------------------------------------------------------
481 -- Update and black-hole wrappers
482 ------------------------------------------------------------------------
484 blackHoleIt :: ClosureInfo -> FCode ()
485 -- Only called for closures with no args
486 -- Node points to the closure
487 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
489 emitBlackHoleCode :: Bool -> FCode ()
490 emitBlackHoleCode is_single_entry
491 | eager_blackholing = do
492 tickyBlackHole (not is_single_entry)
493 emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
497 bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
498 | otherwise = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info")
500 -- If we wanted to do eager blackholing with slop filling,
501 -- we'd need to do it at the *end* of a basic block, otherwise
502 -- we overwrite the free variables in the thunk that we still
503 -- need. We have a patch for this from Andy Cheadle, but not
504 -- incorporated yet. --SDM [6/2004]
506 -- Profiling needs slop filling (to support LDV profiling), so
507 -- currently eager blackholing doesn't work with profiling.
509 -- Previously, eager blackholing was enabled when ticky-ticky
510 -- was on. But it didn't work, and it wasn't strictly necessary
511 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
512 -- is unconditionally disabled. -- krc 1/2007
514 eager_blackholing = False
516 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
517 -- Nota Bene: this function does not change Node (even if it's a CAF),
518 -- so that the cost centre in the original closure can still be
519 -- extracted by a subsequent enterCostCentre
520 setupUpdate closure_info node body
521 | closureReEntrant closure_info
524 | not (isStaticClosure closure_info)
525 = if closureUpdReqd closure_info
526 then do { tickyPushUpdateFrame;
527 ; pushUpdateFrame [CmmReg (CmmLocal node),
528 mkLblExpr mkUpdInfoLabel] body }
529 else do { tickyUpdateFrameOmitted; body}
531 | otherwise -- A static closure
532 = do { tickyUpdateBhCaf closure_info
534 ; if closureUpdReqd closure_info
535 then do -- Blackhole the (updatable) CAF:
536 { upd_closure <- link_caf closure_info True
537 ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
538 mkLblExpr mkUpdInfoLabel] body }
539 else do {tickyUpdateFrameOmitted; body}
542 -- Push the update frame on the stack in the Entry area,
543 -- leaving room for the return address that is already
544 -- at the old end of the area.
545 pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
546 pushUpdateFrame es body
547 = do updfr <- getUpdFrameOff
548 offset <- foldM push updfr es
549 withUpdFrameOff offset body
551 do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
553 where base = off + widthInBytes (cmmExprWidth e)
555 -----------------------------------------------------------------------------
558 -- When a CAF is first entered, it creates a black hole in the heap,
559 -- and updates itself with an indirection to this new black hole.
561 -- We update the CAF with an indirection to a newly-allocated black
562 -- hole in the heap. We also set the blocking queue on the newly
563 -- allocated black hole to be empty.
565 -- Why do we make a black hole in the heap when we enter a CAF?
567 -- - for a generational garbage collector, which needs a fast
568 -- test for whether an updatee is in an old generation or not
570 -- - for the parallel system, which can implement updates more
571 -- easily if the updatee is always in the heap. (allegedly).
573 -- When debugging, we maintain a separate CAF list so we can tell when
574 -- a CAF has been garbage collected.
576 -- newCAF must be called before the itbl ptr is overwritten, since
577 -- newCAF records the old itbl ptr in order to do CAF reverting
578 -- (which Hugs needs to do in order that combined mode works right.)
581 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
582 -- into the "newCAF" RTS procedure, which we call anyway, including
583 -- the allocation of the black-hole indirection closure.
584 -- That way, code size would fall, the CAF-handling code would
585 -- be closer together, and the compiler wouldn't need to know
586 -- about off_indirectee etc.
588 link_caf :: ClosureInfo
589 -> Bool -- True <=> updatable, False <=> single-entry
590 -> FCode LocalReg -- Returns amode for closure to be updated
591 -- To update a CAF we must allocate a black hole, link the CAF onto the
592 -- CAF list, then update the CAF to point to the fresh black hole.
593 -- This function returns the address of the black hole, so it can be
594 -- updated with the new value when available. The reason for all of this
595 -- is that we only want to update dynamic heap objects, not static ones,
596 -- so that generational GC is easier.
597 link_caf cl_info _is_upd = do
598 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
599 ; let use_cc = costCentreFrom (CmmReg nodeReg)
601 ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
604 -- Call the RTS function newCAF to add the CAF to the CafList
605 -- so that the garbage collector can find them
606 -- This must be done *before* the info table pointer is overwritten,
607 -- because the old info table ptr is needed for reversion
608 ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
609 [ (CmmReg (CmmGlobal BaseReg), AddrHint),
610 (CmmReg nodeReg, AddrHint) ]
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.