2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CgClosure]{Code generation for closures}
6 This module provides the support code for @StgToAbstractC@ to deal
7 with {\em closures} on the RHSs of let(rec)s. See also
8 @CgCon@, which deals with constructors.
11 #include "HsVersions.h"
13 module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
19 import PrelInfo ( PrimOp(..), Name
20 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
21 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
23 import Type ( isPrimType, isPrimTyCon,
24 getTauType, showTypeCategory, getTyConDataCons
26 import CgBindery ( getCAddrMode, getAtomAmodes,
28 bindNewToNode, bindNewToAStack, bindNewToBStack,
29 bindNewToReg, bindArgsToRegs
31 import CgCompInfo ( spARelToInt, spBRelToInt )
32 import CgExpr ( cgExpr, cgSccExpr )
33 import CgUpdate ( pushUpdateFrame )
34 import CgHeapery ( allocDynClosure, heapCheck
36 , heapCheckOnly, fetchAndReschedule -- HWL
39 import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
40 CtrlReturnConvention(..), DataReturnConvention(..)
42 import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
45 import CgUsages ( getVirtSps, setRealAndVirtualSps,
46 getSpARelOffset, getSpBRelOffset,
50 import ClosureInfo -- lots and lots of stuff
52 import Id ( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe,
53 showId, getIdInfo, getIdStrictness,
57 import ListSetOps ( minusList )
58 import Maybes ( Maybe(..), maybeToBool )
59 import PrimRep ( isFollowableRep )
65 %********************************************************
67 \subsection[closures-no-free-vars]{Top-level closures}
69 %********************************************************
71 For closures bound at top level, allocate in static space.
72 They should have no free variables.
76 -> CostCentre -- Optional cost centre annotation
81 -> FCode (Id, CgIdInfo)
83 cgTopRhsClosure name cc binder_info args body lf_info
84 = -- LAY OUT THE OBJECT
86 closure_info = layOutStaticNoFVClosure name lf_info
89 -- GENERATE THE INFO TABLE (IF NECESSARY)
90 forkClosureBody (closureCodeBody binder_info closure_info
94 -- BUILD VAP INFO TABLES IF NECESSARY
95 -- Don't build Vap info tables etc for
96 -- a function whose result is an unboxed type,
97 -- because we can never have thunks with such a type.
98 (if closureReturnsUnboxedType closure_info then
102 bind_the_fun = addBindC name cg_id_info -- It's global!
104 cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
107 -- BUILD THE OBJECT (IF NECESSARY)
108 (if staticClosureRequired name binder_info lf_info
111 cost_centre = mkCCostCentre cc
114 closure_label -- Labelled with the name on lhs of defn
122 returnFC (name, cg_id_info)
124 closure_label = mkClosureLabel name
125 cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
128 %********************************************************
130 \subsection[non-top-level-closures]{Non top-level closures}
132 %********************************************************
134 For closures with free vars, allocate in heap.
136 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
138 -- Closures which (a) have no fvs and (b) have some args (i.e.
139 -- combinator functions), are allocated statically, just as if they
140 -- were top-level closures. We can't get a space leak that way
141 -- (because they are HNFs) and it saves allocation.
143 -- Lexical Scoping: Problem
144 -- These top level function closures will be inherited, possibly
145 -- to a different cost centre scope set before entering.
147 -- Evaluation Scoping: ok as already in HNF
149 -- Should rely on floating mechanism to achieve this floating to top level.
150 -- As let floating will avoid floating which breaks cost centre attribution
151 -- everything will be OK.
153 -- Disabled: because it breaks lexical-scoped cost centre semantics.
154 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
155 -- = cgTopRhsClosure binder cc bi upd_flag args body
157 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
161 -> CostCentre -- Optional cost centre annotation
167 -> FCode (Id, CgIdInfo)
169 cgRhsClosure binder cc binder_info fvs args body lf_info
170 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
171 -- ToDo: check non-primitiveness (ASSERT)
173 -- LAY OUT THE OBJECT
174 getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
176 (closure_info, amodes_w_offsets)
177 = layOutDynClosure binder getAmodeRep amodes lf_info
179 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
182 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
184 `thenFC` \ heap_offset ->
187 returnFC (binder, heapIdInfo binder heap_offset lf_info)
190 maybe_std_thunk = getStandardFormThunkInfo lf_info
191 Just std_thunk_payload = maybe_std_thunk
194 Here's the general case.
196 cgRhsClosure binder cc binder_info fvs args body lf_info
198 -- LAY OUT THE OBJECT
200 -- If the binder is itself a free variable, then don't store
201 -- it in the closure. Instead, just bind it to Node on entry.
202 -- NB we can be sure that Node will point to it, because we
203 -- havn't told mkClosureLFInfo about this; so if the binder
204 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
205 -- stored in the closure itself, so it will make sure that
206 -- Node points to it...
208 is_elem = isIn "cgRhsClosure"
210 binder_is_a_fv = binder `is_elem` fvs
211 reduced_fvs = if binder_is_a_fv
212 then fvs `minusList` [binder]
215 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
217 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
219 closure_info :: ClosureInfo
220 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
222 (closure_info, bind_details)
223 = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
225 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
227 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
229 get_kind (id, amode_and_info) = getIdPrimRep id
231 -- BUILD ITS INFO TABLE AND CODE
234 mapCs bind_fv bind_details `thenC`
236 -- Bind the binder itself, if it is a free var
237 (if binder_is_a_fv then
238 bindNewToReg binder node lf_info
243 closureCodeBody binder_info closure_info cc args body
246 -- BUILD VAP INFO TABLES IF NECESSARY
247 -- Don't build Vap info tables etc for
248 -- a function whose result is an unboxed type,
249 -- because we can never have thunks with such a type.
250 (if closureReturnsUnboxedType closure_info then
253 cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
258 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
260 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
261 ) `thenFC` \ heap_offset ->
264 returnFC (binder, heapIdInfo binder heap_offset lf_info)
267 @cgVapInfoTables@ generates both Vap info tables, if they are required
268 at all. It calls @cgVapInfoTable@ to generate each Vap info table,
269 along with its entry code.
272 -- Don't generate Vap info tables for thunks; only for functions
273 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
276 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
277 = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
278 (if stdVapRequired binder_info then
279 cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
284 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
285 (if noUpdVapRequired binder_info then
286 cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
292 fun_in_payload = not top_level
294 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
296 -- The vap_entry_rhs is a manufactured STG expression which
297 -- looks like the RHS of any binding which is going to use the vap-entry
298 -- point of the function. Each of these bindings will look like:
300 -- x = [a,b,c] \upd [] -> f a b c
302 -- If f is not top-level, then f is one of the free variables too,
303 -- hence "payload_ids" isn't the same as "arg_ids".
305 vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
308 arg_ids_w_info = [(name,mkLFArgument) | name <- args]
309 payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
310 | otherwise = arg_ids_w_info
312 payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
315 vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
316 upd_flag [] vap_entry_rhs
317 -- It's not top level, even if we're currently compiling a top-level
318 -- function, because any VAP *use* of this function will be for a
320 -- let x = f p q -- x isn't top level!
323 get_kind (id, info) = getIdPrimRep id
325 payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
326 (closure_info, payload_bind_details) = layOutDynClosure
328 get_kind payload_ids_w_info
330 -- The dodgy thing is that we use the "fun" as the
331 -- Id to give to layOutDynClosure. This Id gets embedded in
332 -- the closure_info it returns. But of course, the function doesn't
333 -- have the right type to match the Vap closure. Never mind,
334 -- a hack in closureType spots the special case. Otherwise that
335 -- Id is just used for label construction, which is OK.
337 bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
340 -- BUILD ITS INFO TABLE AND CODE
343 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
344 -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
345 perhaps_bind_the_fun `thenC`
346 mapCs bind_fv payload_bind_details `thenC`
348 -- Generate the info table and code
349 closureCodeBody NoStgBinderInfo
352 [] -- No args; it's a thunk
356 %************************************************************************
358 \subsection[code-for-closures]{The code for closures}
360 %************************************************************************
363 closureCodeBody :: StgBinderInfo
364 -> ClosureInfo -- Lots of information about this closure
365 -> CostCentre -- Optional cost centre attached to closure
371 There are two main cases for the code for closures. If there are {\em
372 no arguments}, then the closure is a thunk, and not in normal form.
373 So it should set up an update frame (if it is shared). Also, it has
374 no argument satisfaction check, so fast and slow entry-point labels
378 closureCodeBody binder_info closure_info cc [] body
379 = -- thunks cannot have a primitive type!
383 = case (closureType closure_info) of
384 Nothing -> (False, panic "debug")
385 Just (tc,_,_) -> (True, tc)
387 if has_tycon && isPrimTyCon tycon then
388 pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
391 getAbsC body_code `thenFC` \ body_absC ->
392 moduleName `thenFC` \ mod_name ->
393 getIntSwitchChkrC `thenFC` \ isw_chkr ->
395 absC (CClosureInfoAndCode closure_info body_absC Nothing
396 stdUpd (cl_descr mod_name)
397 (dataConLiveness isw_chkr closure_info))
399 cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
401 body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
402 body_code = profCtrC SLIT("ENT_THK") [] `thenC`
403 enterCostCentreCode closure_info cc IsThunk `thenC`
404 thunkWrapper closure_info (cgSccExpr body)
406 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
409 If there is {\em at least one argument}, then this closure is in
410 normal form, so there is no need to set up an update frame. On the
411 other hand, we do have to check that there are enough args, and
412 perform an update if not!
414 The Macros for GrAnSim are produced at the beginning of the
415 argSatisfactionCheck (by calling fetchAndReschedule). There info if
416 Node points to closure is available. -- HWL
419 closureCodeBody binder_info closure_info cc all_args body
420 = getEntryConvention id lf_info
421 (map getIdPrimRep all_args) `thenFC` \ entry_conv ->
423 isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
425 isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
427 isStringSwitchSetC AsmTarget `thenFC` \ native_code ->
430 stg_arity = length all_args
432 -- Arg mapping for standard (slow) entry point; all args on stack
433 (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
435 0 0 -- Initial virtual SpA, SpB
439 -- Arg mapping for the fast entry point; as many args as poss in
440 -- registers; the rest on the stack
441 -- arg_regs are the registers used for arg passing
442 -- stk_args are the args which are passed on the stack
444 arg_regs = case entry_conv of
445 DirectEntry lbl arity regs -> regs
446 ViaNode | is_concurrent -> []
447 other -> panic "closureCodeBody:arg_regs"
449 stk_args = drop (length arg_regs) all_args
450 (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
452 0 0 -- Initial virtual SpA, SpB
456 -- HWL; Note: empty list of live regs in slow entry code
457 -- Old version (reschedule combined with heap check);
458 -- see argSatisfactionCheck for new version
459 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
460 -- where node = VanillaReg PtrRep 1
461 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
464 = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
466 -- Bind args, and record expected position of stk ptrs
467 mapCs bindNewToAStack all_bxd_w_offsets `thenC`
468 mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
469 setRealAndVirtualSps spA_all_args spB_all_args `thenC`
471 argSatisfactionCheck closure_info all_args `thenC`
473 -- OK, so there are enough args. Now we need to stuff as
474 -- many of them in registers as the fast-entry code
475 -- expects Note that the zipWith will give up when it hits
476 -- the end of arg_regs.
478 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
479 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
481 -- Now adjust real stack pointers
482 adjustRealSps spA_stk_args spB_stk_args `thenC`
484 -- set the arity checker, if asked
487 then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
490 absC (CFallThrough (CLbl fast_label CodePtrRep))
492 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
495 -- Old version (reschedule combined with heap check);
496 -- see argSatisfactionCheck for new version
497 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
500 = profCtrC SLIT("ENT_FUN_DIRECT") [
501 CLbl (mkRednCountsLabel id) PtrRep,
502 CString (_PK_ (showId PprDebug id)),
503 mkIntCLit stg_arity, -- total # of args
504 mkIntCLit spA_stk_args, -- # passed on A stk
505 mkIntCLit spB_stk_args, -- B stk (rest in regs)
506 CString (_PK_ (map (showTypeCategory . idType) all_args)),
507 CString (_PK_ (show_wrapper_name wrapper_maybe)),
508 CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
512 then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
516 -- Bind args to regs/stack as appropriate, and
517 -- record expected position of sps
518 bindArgsToRegs all_args arg_regs `thenC`
519 mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
520 mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
521 setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
523 -- Enter the closures cc, if required
524 enterCostCentreCode closure_info cc IsFunction `thenC`
527 funWrapper closure_info arg_regs (cgExpr body)
529 -- Make a labelled code-block for the slow and fast entry code
530 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
531 `thenFC` \ slow_abs_c ->
532 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
533 moduleName `thenFC` \ mod_name ->
534 getIntSwitchChkrC `thenFC` \ isw_chkr ->
536 -- Now either construct the info table, or put the fast code in alone
537 -- (We never have slow code without an info table)
539 if info_table_needed then
540 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
541 stdUpd (cl_descr mod_name)
542 (dataConLiveness isw_chkr closure_info)
544 CCodeBlock fast_label fast_abs_c
547 lf_info = closureLFInfo closure_info
549 cl_descr mod_name = closureDescription mod_name id all_args body
551 -- Figure out what is needed and what isn't
552 slow_code_needed = slowFunEntryCodeRequired id binder_info
553 info_table_needed = funInfoTableRequired id binder_info lf_info
555 -- Manufacture labels
556 id = closureId closure_info
558 fast_label = fastLabelFromCI closure_info
560 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
562 wrapper_maybe = get_ultimate_wrapper Nothing id
564 get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
565 = case (myWrapperMaybe x) of
567 Just xx -> get_ultimate_wrapper (Just xx) xx
569 show_wrapper_name Nothing = ""
570 show_wrapper_name (Just xx) = showId PprDebug xx
572 show_wrapper_arg_kinds Nothing = ""
573 show_wrapper_arg_kinds (Just xx)
574 = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
579 For lexically scoped profiling we have to load the cost centre from
580 the closure entered, if the costs are not supposed to be inherited.
581 This is done immediately on entering the fast entry point.
583 Load current cost centre from closure, if not inherited.
584 Node is guaranteed to point to it, if profiling and not inherited.
587 data IsThunk = IsThunk | IsFunction -- Bool-like, local
589 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
591 enterCostCentreCode closure_info cc is_thunk
592 = costCentresFlag `thenFC` \ profiling_on ->
593 if not profiling_on then
595 else -- down to business
596 ASSERT(not (noCostCentreAttached cc))
598 if costsAreSubsumed cc then
601 else if is_current_CC cc then -- fish the CC out of the closure,
602 -- where we put it when we alloc'd;
603 -- NB: chk defn of "is_current_CC"
604 -- if you go to change this! (WDP 94/12)
607 IsThunk -> SLIT("ENTER_CC_TCL")
608 IsFunction -> SLIT("ENTER_CC_FCL"))
611 else if isCafCC cc then
616 else -- we've got a "real" cost centre right here in our hands...
619 IsThunk -> SLIT("ENTER_CC_T")
620 IsFunction -> SLIT("ENTER_CC_F"))
624 = currentOrSubsumedCosts cc
625 -- but we've already ruled out "subsumed", so it must be "current"!
628 %************************************************************************
630 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
632 %************************************************************************
634 The argument-satisfaction check code is placed after binding
635 the arguments to their stack locations. Hence, the virtual stack
636 pointer is pointing after all the args, and virtual offset 1 means
637 the base of frame and hence most distant arg. Hence
638 virtual offset 0 is just beyond the most distant argument; the
639 relative offset of this word tells how many words of arguments
643 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
645 argSatisfactionCheck closure_info [] = nopC
647 argSatisfactionCheck closure_info args
648 = -- safest way to determine which stack last arg will be on:
649 -- look up CAddrMode that last arg is bound to;
651 -- check isFollowableRep.
653 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
657 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
658 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
660 then fetchAndReschedule [] node_points
661 else absC AbsCNop) `thenC`
664 getCAddrMode (last args) `thenFC` \ last_amode ->
666 if (isFollowableRep (getAmodeRep last_amode)) then
667 getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
669 absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)])
671 absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
672 [mkIntCLit (spARelToInt spA off), set_Node_to_this])
674 getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
676 absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
678 absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
679 [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
681 -- We must tell the arg-satis macro whether Node is pointing to
682 -- the closure or not. If it isn't so pointing, then we give to
683 -- the macro the (static) address of the closure.
685 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
688 %************************************************************************
690 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
692 %************************************************************************
695 thunkWrapper:: ClosureInfo -> Code -> Code
696 thunkWrapper closure_info thunk_code
697 = -- Stack and heap overflow checks
698 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
701 -- HWL insert macros for GrAnSim if node is live here
703 then fetchAndReschedule [] node_points
704 else absC AbsCNop) `thenC`
707 stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
709 -- Must be after stackCheck: if stchk fails new stack
710 -- space has to be allocated from the heap
712 heapCheck [] node_points (
713 -- heapCheck *encloses* the rest
714 -- The "[]" says there are no live argument registers
716 -- Overwrite with black hole if necessary
717 blackHoleIt closure_info `thenC`
719 -- Push update frame if necessary
720 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
724 funWrapper :: ClosureInfo -- Closure whose code body this is
725 -> [MagicId] -- List of argument registers (if any)
726 -> Code -- Body of function being compiled
728 funWrapper closure_info arg_regs fun_body
729 = -- Stack overflow check
730 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
731 stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
733 -- Heap overflow check
734 heapCheck arg_regs node_points (
735 -- heapCheck *encloses* the rest
737 -- Finally, do the business
742 %************************************************************************
744 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
746 %************************************************************************
748 Assumption: virtual and real stack pointers are currently exactly aligned.
751 stackCheck :: ClosureInfo
752 -> [MagicId] -- Live registers
753 -> Bool -- Node required to point after check?
757 stackCheck closure_info regs node_reqd code
758 = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
760 getVirtSps `thenFC` \ (vSpA, vSpB) ->
762 let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
763 b_headroom_reqd = bHw - vSpB
766 absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
769 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
770 mkIntCLit a_headroom_reqd,
771 mkIntCLit b_headroom_reqd,
774 mkIntCLit (if returns_prim_type then 1 else 0),
775 mkIntCLit (if node_reqd then 1 else 0)]
777 -- The test is *inside* the absC, to avoid black holes!
782 all_regs = if node_reqd then node:regs else regs
783 liveness_mask = mkLiveRegsBitMask all_regs
785 returns_prim_type = closureReturnsUnboxedType closure_info
788 %************************************************************************
790 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
792 %************************************************************************
796 blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
797 blackHoleIt closure_info
798 = noBlackHolingFlag `thenFC` \ no_black_holing ->
800 if (blackHoleOnEntry no_black_holing closure_info)
802 absC (if closureSingleEntry(closure_info) then
803 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
805 CMacroStmt UPD_BH_UPDATABLE [CReg node])
806 -- Node always points to it; see stg-details
812 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
813 -- Nota Bene: this function does not change Node (even if it's a CAF),
814 -- so that the cost centre in the original closure can still be
815 -- extracted by a subsequent ENTER_CC_TCL
817 setupUpdate closure_info code
818 = if (closureUpdReqd closure_info) then
819 link_caf_if_needed `thenFC` \ update_closure ->
820 getIntSwitchChkrC `thenFC` \ isw_chkr ->
821 pushUpdateFrame update_closure (vector isw_chkr) code
823 profCtrC SLIT("UPDF_OMITTED") [] `thenC`
826 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
828 = if not (isStaticClosure closure_info) then
832 -- First we must allocate a black hole, and link the
833 -- CAF onto the CAF list
835 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
836 -- Hack Warning: Using a CLitLit to get CAddrMode !
838 use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
841 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
842 `thenFC` \ heap_offset ->
843 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
844 let amode = CAddr hp_rel
846 absC (CMacroStmt UPD_CAF [CReg node, amode])
850 closure_label = mkClosureLabel (closureId closure_info)
853 = case (closureType closure_info) of
854 Nothing -> CReg StdUpdRetVecReg
855 Just (spec_tycon, _, spec_datacons) ->
856 case (ctrlReturnConvAlg spec_tycon) of
857 UnvectoredReturn 1 ->
859 spec_data_con = head spec_datacons
860 only_tag = getDataConTag spec_data_con
862 direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
863 ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
864 ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
866 vectored = mkStdUpdVecTblLabel spec_tycon
868 CUnVecLbl direct vectored
870 UnvectoredReturn _ -> CReg StdUpdRetVecReg
871 VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
874 %************************************************************************
876 \subsection[CgClosure-Description]{Profiling Closure Description.}
878 %************************************************************************
880 For "global" data constructors the description is simply occurrence
881 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
883 Otherwise it is determind by @closureDescription@ from the let
887 closureDescription :: FAST_STRING -- Module
888 -> Id -- Id of closure binding
893 -- Not called for StgRhsCon which have global info tables built in
894 -- CgConTbls.lhs with a description generated from the data constructor
896 closureDescription mod_name name args body =
897 uppShow 0 (prettyToUn (
898 ppBesides [ppChar '<',
906 chooseDynCostCentres cc args fvs body
908 use_cc -- cost-centre we record in the object
909 = if currentOrSubsumedCosts cc
910 then CReg CurCostCentre
911 else mkCCostCentre cc
913 blame_cc -- cost-centre on whom we blame the allocation
914 = case (args, fvs, body) of
915 ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
917 -> mkCCostCentre overheadCostCentre
919 -- if it's an utterly trivial RHS, then it must be
920 -- one introduced by boxHigherOrderArgs for profiling,
921 -- so we charge it to "OVERHEAD".