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