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
16 import CgLoop2 ( cgExpr, cgSccExpr )
22 import AbsCUtils ( mkAbstractCs, getAmodeRep )
23 import CgBindery ( getCAddrMode, getArgAmodes,
24 getCAddrModeAndInfo, bindNewToNode,
25 bindNewToAStack, bindNewToBStack,
26 bindNewToReg, bindArgsToRegs,
27 stableAmodeIdInfo, heapIdInfo
29 import CgCompInfo ( spARelToInt, spBRelToInt )
30 import CgUpdate ( pushUpdateFrame )
31 import CgHeapery ( allocDynClosure, heapCheck
33 , fetchAndReschedule -- HWL
36 import CgRetConv ( mkLiveRegsMask,
37 ctrlReturnConvAlg, dataReturnConvAlg,
38 CtrlReturnConvention(..), DataReturnConvention(..)
40 import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
43 import CgUsages ( getVirtSps, setRealAndVirtualSps,
44 getSpARelOffset, getSpBRelOffset,
47 import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
48 mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
49 mkErrorStdEntryLabel, mkRednCountsLabel
51 import ClosureInfo -- lots and lots of stuff
52 import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent,
55 import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
56 noCostCentreAttached, costsAreSubsumed,
57 isCafCC, overheadCostCentre
59 import HeapOffs ( VirtualHeapOffset(..) )
60 import Id ( idType, idPrimRep,
61 showId, getIdStrictness, dataConTag,
63 GenId{-instance Outputable-}
65 import ListSetOps ( minusList )
66 import Maybes ( maybeToBool )
67 import PprStyle ( PprStyle(..) )
68 import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
69 import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr )
70 import PrimRep ( isFollowableRep, PrimRep(..) )
71 import TyCon ( isPrimTyCon, tyConDataCons )
72 import Unpretty ( uppShow )
73 import Util ( isIn, panic, pprPanic, assertPanic )
75 myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
76 showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
77 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
80 %********************************************************
82 \subsection[closures-no-free-vars]{Top-level closures}
84 %********************************************************
86 For closures bound at top level, allocate in static space.
87 They should have no free variables.
91 -> CostCentre -- Optional cost centre annotation
96 -> FCode (Id, CgIdInfo)
98 cgTopRhsClosure name cc binder_info args body lf_info
99 = -- LAY OUT THE OBJECT
101 closure_info = layOutStaticNoFVClosure name lf_info
104 -- GENERATE THE INFO TABLE (IF NECESSARY)
105 forkClosureBody (closureCodeBody binder_info closure_info
109 -- BUILD VAP INFO TABLES IF NECESSARY
110 -- Don't build Vap info tables etc for
111 -- a function whose result is an unboxed type,
112 -- because we can never have thunks with such a type.
113 (if closureReturnsUnboxedType closure_info then
117 bind_the_fun = addBindC name cg_id_info -- It's global!
119 cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
122 -- BUILD THE OBJECT (IF NECESSARY)
123 (if staticClosureRequired name binder_info lf_info
126 cost_centre = mkCCostCentre cc
129 closure_label -- Labelled with the name on lhs of defn
137 returnFC (name, cg_id_info)
139 closure_label = mkClosureLabel name
140 cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
143 %********************************************************
145 \subsection[non-top-level-closures]{Non top-level closures}
147 %********************************************************
149 For closures with free vars, allocate in heap.
151 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
153 -- Closures which (a) have no fvs and (b) have some args (i.e.
154 -- combinator functions), are allocated statically, just as if they
155 -- were top-level closures. We can't get a space leak that way
156 -- (because they are HNFs) and it saves allocation.
158 -- Lexical Scoping: Problem
159 -- These top level function closures will be inherited, possibly
160 -- to a different cost centre scope set before entering.
162 -- Evaluation Scoping: ok as already in HNF
164 -- Should rely on floating mechanism to achieve this floating to top level.
165 -- As let floating will avoid floating which breaks cost centre attribution
166 -- everything will be OK.
168 -- Disabled: because it breaks lexical-scoped cost centre semantics.
169 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
170 -- = cgTopRhsClosure binder cc bi upd_flag args body
172 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
176 -> CostCentre -- Optional cost centre annotation
182 -> FCode (Id, CgIdInfo)
184 cgRhsClosure binder cc binder_info fvs args body lf_info
185 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
186 -- ToDo: check non-primitiveness (ASSERT)
188 -- LAY OUT THE OBJECT
189 getArgAmodes std_thunk_payload `thenFC` \ amodes ->
191 (closure_info, amodes_w_offsets)
192 = layOutDynClosure binder getAmodeRep amodes lf_info
194 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
197 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
199 `thenFC` \ heap_offset ->
202 returnFC (binder, heapIdInfo binder heap_offset lf_info)
205 maybe_std_thunk = getStandardFormThunkInfo lf_info
206 Just std_thunk_payload = maybe_std_thunk
209 Here's the general case.
211 cgRhsClosure binder cc binder_info fvs args body lf_info
213 -- LAY OUT THE OBJECT
215 -- If the binder is itself a free variable, then don't store
216 -- it in the closure. Instead, just bind it to Node on entry.
217 -- NB we can be sure that Node will point to it, because we
218 -- havn't told mkClosureLFInfo about this; so if the binder
219 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
220 -- stored in the closure itself, so it will make sure that
221 -- Node points to it...
223 is_elem = isIn "cgRhsClosure"
225 binder_is_a_fv = binder `is_elem` fvs
226 reduced_fvs = if binder_is_a_fv
227 then fvs `minusList` [binder]
230 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
232 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
234 closure_info :: ClosureInfo
235 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
237 (closure_info, bind_details)
238 = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
240 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
242 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
244 get_kind (id, amode_and_info) = idPrimRep id
246 -- BUILD ITS INFO TABLE AND CODE
249 mapCs bind_fv bind_details `thenC`
251 -- Bind the binder itself, if it is a free var
252 (if binder_is_a_fv then
253 bindNewToReg binder node lf_info
258 closureCodeBody binder_info closure_info cc args body
261 -- BUILD VAP INFO TABLES IF NECESSARY
262 -- Don't build Vap info tables etc for
263 -- a function whose result is an unboxed type,
264 -- because we can never have thunks with such a type.
265 (if closureReturnsUnboxedType closure_info then
268 cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
273 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
275 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
276 ) `thenFC` \ heap_offset ->
279 returnFC (binder, heapIdInfo binder heap_offset lf_info)
282 @cgVapInfoTables@ generates both Vap info tables, if they are required
283 at all. It calls @cgVapInfoTable@ to generate each Vap info table,
284 along with its entry code.
287 -- Don't generate Vap info tables for thunks; only for functions
288 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
291 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
292 = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
293 (if stdVapRequired binder_info then
294 cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
299 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
300 (if noUpdVapRequired binder_info then
301 cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
307 fun_in_payload = not top_level
309 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
311 -- The vap_entry_rhs is a manufactured STG expression which
312 -- looks like the RHS of any binding which is going to use the vap-entry
313 -- point of the function. Each of these bindings will look like:
315 -- x = [a,b,c] \upd [] -> f a b c
317 -- If f is not top-level, then f is one of the free variables too,
318 -- hence "payload_ids" isn't the same as "arg_ids".
320 vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
323 arg_ids_w_info = [(name,mkLFArgument) | name <- args]
324 payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
325 | otherwise = arg_ids_w_info
327 payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
330 vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
331 upd_flag [] vap_entry_rhs
332 -- It's not top level, even if we're currently compiling a top-level
333 -- function, because any VAP *use* of this function will be for a
335 -- let x = f p q -- x isn't top level!
338 get_kind (id, info) = idPrimRep id
340 payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
341 (closure_info, payload_bind_details) = layOutDynClosure
343 get_kind payload_ids_w_info
345 -- The dodgy thing is that we use the "fun" as the
346 -- Id to give to layOutDynClosure. This Id gets embedded in
347 -- the closure_info it returns. But of course, the function doesn't
348 -- have the right type to match the Vap closure. Never mind,
349 -- a hack in closureType spots the special case. Otherwise that
350 -- Id is just used for label construction, which is OK.
352 bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
355 -- BUILD ITS INFO TABLE AND CODE
358 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
359 -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
360 perhaps_bind_the_fun `thenC`
361 mapCs bind_fv payload_bind_details `thenC`
363 -- Generate the info table and code
364 closureCodeBody NoStgBinderInfo
367 [] -- No args; it's a thunk
371 %************************************************************************
373 \subsection[code-for-closures]{The code for closures}
375 %************************************************************************
378 closureCodeBody :: StgBinderInfo
379 -> ClosureInfo -- Lots of information about this closure
380 -> CostCentre -- Optional cost centre attached to closure
386 There are two main cases for the code for closures. If there are {\em
387 no arguments}, then the closure is a thunk, and not in normal form.
388 So it should set up an update frame (if it is shared). Also, it has
389 no argument satisfaction check, so fast and slow entry-point labels
393 closureCodeBody binder_info closure_info cc [] body
394 = -- thunks cannot have a primitive type!
398 = case (closureType closure_info) of
399 Nothing -> (False, panic "debug")
400 Just (tc,_,_) -> (True, tc)
402 if has_tycon && isPrimTyCon tycon then
403 pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
406 getAbsC body_code `thenFC` \ body_absC ->
407 moduleName `thenFC` \ mod_name ->
409 absC (CClosureInfoAndCode closure_info body_absC Nothing
410 stdUpd (cl_descr mod_name)
411 (dataConLiveness closure_info))
413 cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
415 body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
416 body_code = profCtrC SLIT("ENT_THK") [] `thenC`
417 enterCostCentreCode closure_info cc IsThunk `thenC`
418 thunkWrapper closure_info (cgSccExpr body)
420 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
423 If there is {\em at least one argument}, then this closure is in
424 normal form, so there is no need to set up an update frame. On the
425 other hand, we do have to check that there are enough args, and
426 perform an update if not!
428 The Macros for GrAnSim are produced at the beginning of the
429 argSatisfactionCheck (by calling fetchAndReschedule). There info if
430 Node points to closure is available. -- HWL
433 closureCodeBody binder_info closure_info cc all_args body
434 = getEntryConvention id lf_info
435 (map idPrimRep all_args) `thenFC` \ entry_conv ->
437 do_arity_chks = opt_EmitArityChecks
438 is_concurrent = opt_ForConcurrent
439 native_code = opt_AsmTarget
441 stg_arity = length all_args
443 -- Arg mapping for standard (slow) entry point; all args on stack
444 (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
446 0 0 -- Initial virtual SpA, SpB
450 -- Arg mapping for the fast entry point; as many args as poss in
451 -- registers; the rest on the stack
452 -- arg_regs are the registers used for arg passing
453 -- stk_args are the args which are passed on the stack
455 arg_regs = case entry_conv of
456 DirectEntry lbl arity regs -> regs
457 ViaNode | is_concurrent -> []
458 other -> panic "closureCodeBody:arg_regs"
460 stk_args = drop (length arg_regs) all_args
461 (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
463 0 0 -- Initial virtual SpA, SpB
467 -- HWL; Note: empty list of live regs in slow entry code
468 -- Old version (reschedule combined with heap check);
469 -- see argSatisfactionCheck for new version
470 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
471 -- where node = VanillaReg PtrRep 1
472 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
475 = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
477 -- Bind args, and record expected position of stk ptrs
478 mapCs bindNewToAStack all_bxd_w_offsets `thenC`
479 mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
480 setRealAndVirtualSps spA_all_args spB_all_args `thenC`
482 argSatisfactionCheck closure_info all_args `thenC`
484 -- OK, so there are enough args. Now we need to stuff as
485 -- many of them in registers as the fast-entry code
486 -- expects Note that the zipWith will give up when it hits
487 -- the end of arg_regs.
489 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
490 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
492 -- Now adjust real stack pointers
493 adjustRealSps spA_stk_args spB_stk_args `thenC`
495 -- set the arity checker, if asked
498 then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
501 absC (CFallThrough (CLbl fast_label CodePtrRep))
503 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
506 -- Old version (reschedule combined with heap check);
507 -- see argSatisfactionCheck for new version
508 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
511 = profCtrC SLIT("ENT_FUN_DIRECT") [
512 CLbl (mkRednCountsLabel id) PtrRep,
513 CString (_PK_ (showId PprDebug id)),
514 mkIntCLit stg_arity, -- total # of args
515 mkIntCLit spA_stk_args, -- # passed on A stk
516 mkIntCLit spB_stk_args, -- B stk (rest in regs)
517 CString (_PK_ (map (showTypeCategory . idType) all_args)),
518 CString (_PK_ (show_wrapper_name wrapper_maybe)),
519 CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
523 then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
527 -- Bind args to regs/stack as appropriate, and
528 -- record expected position of sps
529 bindArgsToRegs all_args arg_regs `thenC`
530 mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
531 mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
532 setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
534 -- Enter the closures cc, if required
535 enterCostCentreCode closure_info cc IsFunction `thenC`
538 funWrapper closure_info arg_regs (cgExpr body)
540 -- Make a labelled code-block for the slow and fast entry code
541 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
542 `thenFC` \ slow_abs_c ->
543 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
544 moduleName `thenFC` \ mod_name ->
546 -- Now either construct the info table, or put the fast code in alone
547 -- (We never have slow code without an info table)
549 if info_table_needed then
550 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
551 stdUpd (cl_descr mod_name)
552 (dataConLiveness closure_info)
554 CCodeBlock fast_label fast_abs_c
557 lf_info = closureLFInfo closure_info
559 cl_descr mod_name = closureDescription mod_name id all_args body
561 -- Figure out what is needed and what isn't
562 slow_code_needed = slowFunEntryCodeRequired id binder_info
563 info_table_needed = funInfoTableRequired id binder_info lf_info
565 -- Manufacture labels
566 id = closureId closure_info
568 fast_label = fastLabelFromCI closure_info
570 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
572 wrapper_maybe = get_ultimate_wrapper Nothing id
574 get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
575 = case (myWrapperMaybe x) of
577 Just xx -> get_ultimate_wrapper (Just xx) xx
579 show_wrapper_name Nothing = ""
580 show_wrapper_name (Just xx) = showId PprDebug xx
582 show_wrapper_arg_kinds Nothing = ""
583 show_wrapper_arg_kinds (Just xx)
584 = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
589 For lexically scoped profiling we have to load the cost centre from
590 the closure entered, if the costs are not supposed to be inherited.
591 This is done immediately on entering the fast entry point.
593 Load current cost centre from closure, if not inherited.
594 Node is guaranteed to point to it, if profiling and not inherited.
597 data IsThunk = IsThunk | IsFunction -- Bool-like, local
599 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
601 enterCostCentreCode closure_info cc is_thunk
602 = costCentresFlag `thenFC` \ profiling_on ->
603 if not profiling_on then
605 else -- down to business
606 ASSERT(not (noCostCentreAttached cc))
608 if costsAreSubsumed cc then
611 else if is_current_CC cc then -- fish the CC out of the closure,
612 -- where we put it when we alloc'd;
613 -- NB: chk defn of "is_current_CC"
614 -- if you go to change this! (WDP 94/12)
617 IsThunk -> SLIT("ENTER_CC_TCL")
618 IsFunction -> SLIT("ENTER_CC_FCL"))
621 else if isCafCC cc then
626 else -- we've got a "real" cost centre right here in our hands...
629 IsThunk -> SLIT("ENTER_CC_T")
630 IsFunction -> SLIT("ENTER_CC_F"))
634 = currentOrSubsumedCosts cc
635 -- but we've already ruled out "subsumed", so it must be "current"!
638 %************************************************************************
640 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
642 %************************************************************************
644 The argument-satisfaction check code is placed after binding
645 the arguments to their stack locations. Hence, the virtual stack
646 pointer is pointing after all the args, and virtual offset 1 means
647 the base of frame and hence most distant arg. Hence
648 virtual offset 0 is just beyond the most distant argument; the
649 relative offset of this word tells how many words of arguments
653 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
655 argSatisfactionCheck closure_info [] = nopC
657 argSatisfactionCheck closure_info args
658 = -- safest way to determine which stack last arg will be on:
659 -- look up CAddrMode that last arg is bound to;
661 -- check isFollowableRep.
663 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
667 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
668 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
670 then fetchAndReschedule [] node_points
671 else absC AbsCNop) `thenC`
674 getCAddrMode (last args) `thenFC` \ last_amode ->
676 if (isFollowableRep (getAmodeRep last_amode)) then
677 getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
679 lit = mkIntCLit (spARelToInt spA off)
682 absC (CMacroStmt ARGS_CHK_A [lit])
684 absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this])
686 getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
688 lit = mkIntCLit (spBRelToInt spB off)
691 absC (CMacroStmt ARGS_CHK_B [lit])
693 absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this])
695 -- We must tell the arg-satis macro whether Node is pointing to
696 -- the closure or not. If it isn't so pointing, then we give to
697 -- the macro the (static) address of the closure.
699 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
702 %************************************************************************
704 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
706 %************************************************************************
709 thunkWrapper:: ClosureInfo -> Code -> Code
710 thunkWrapper closure_info thunk_code
711 = -- Stack and heap overflow checks
712 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
715 -- HWL insert macros for GrAnSim if node is live here
717 then fetchAndReschedule [] node_points
718 else absC AbsCNop) `thenC`
721 stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
723 -- Must be after stackCheck: if stchk fails new stack
724 -- space has to be allocated from the heap
726 heapCheck [] node_points (
727 -- heapCheck *encloses* the rest
728 -- The "[]" says there are no live argument registers
730 -- Overwrite with black hole if necessary
731 blackHoleIt closure_info `thenC`
733 -- Push update frame if necessary
734 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
738 funWrapper :: ClosureInfo -- Closure whose code body this is
739 -> [MagicId] -- List of argument registers (if any)
740 -> Code -- Body of function being compiled
742 funWrapper closure_info arg_regs fun_body
743 = -- Stack overflow check
744 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
745 stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
747 -- Heap overflow check
748 heapCheck arg_regs node_points (
749 -- heapCheck *encloses* the rest
751 -- Finally, do the business
756 %************************************************************************
758 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
760 %************************************************************************
762 Assumption: virtual and real stack pointers are currently exactly aligned.
765 stackCheck :: ClosureInfo
766 -> [MagicId] -- Live registers
767 -> Bool -- Node required to point after check?
771 stackCheck closure_info regs node_reqd code
772 = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
774 getVirtSps `thenFC` \ (vSpA, vSpB) ->
776 let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
777 b_headroom_reqd = bHw - vSpB
780 absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
783 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
784 mkIntCLit a_headroom_reqd,
785 mkIntCLit b_headroom_reqd,
788 mkIntCLit (if returns_prim_type then 1 else 0),
789 mkIntCLit (if node_reqd then 1 else 0)]
791 -- The test is *inside* the absC, to avoid black holes!
796 all_regs = if node_reqd then node:regs else regs
797 liveness_mask = mkLiveRegsMask all_regs
799 returns_prim_type = closureReturnsUnboxedType closure_info
802 %************************************************************************
804 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
806 %************************************************************************
810 blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
811 blackHoleIt closure_info
812 = noBlackHolingFlag `thenFC` \ no_black_holing ->
814 if (blackHoleOnEntry no_black_holing closure_info)
816 absC (if closureSingleEntry(closure_info) then
817 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
819 CMacroStmt UPD_BH_UPDATABLE [CReg node])
820 -- Node always points to it; see stg-details
826 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
827 -- Nota Bene: this function does not change Node (even if it's a CAF),
828 -- so that the cost centre in the original closure can still be
829 -- extracted by a subsequent ENTER_CC_TCL
831 setupUpdate closure_info code
832 = if (closureUpdReqd closure_info) then
833 link_caf_if_needed `thenFC` \ update_closure ->
834 pushUpdateFrame update_closure vector code
836 profCtrC SLIT("UPDF_OMITTED") [] `thenC`
839 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
841 = if not (isStaticClosure closure_info) then
845 -- First we must allocate a black hole, and link the
846 -- CAF onto the CAF list
848 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
849 -- Hack Warning: Using a CLitLit to get CAddrMode !
851 use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
854 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
855 `thenFC` \ heap_offset ->
856 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
857 let amode = CAddr hp_rel
859 absC (CMacroStmt UPD_CAF [CReg node, amode])
863 closure_label = mkClosureLabel (closureId closure_info)
866 = case (closureType closure_info) of
867 Nothing -> CReg StdUpdRetVecReg
868 Just (spec_tycon, _, spec_datacons) ->
869 case (ctrlReturnConvAlg spec_tycon) of
870 UnvectoredReturn 1 ->
872 spec_data_con = head spec_datacons
873 only_tag = dataConTag spec_data_con
875 direct = case (dataReturnConvAlg spec_data_con) of
876 ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
877 ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
879 vectored = mkStdUpdVecTblLabel spec_tycon
881 CUnVecLbl direct vectored
883 UnvectoredReturn _ -> CReg StdUpdRetVecReg
884 VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
887 %************************************************************************
889 \subsection[CgClosure-Description]{Profiling Closure Description.}
891 %************************************************************************
893 For "global" data constructors the description is simply occurrence
894 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
896 Otherwise it is determind by @closureDescription@ from the let
900 closureDescription :: FAST_STRING -- Module
901 -> Id -- Id of closure binding
906 -- Not called for StgRhsCon which have global info tables built in
907 -- CgConTbls.lhs with a description generated from the data constructor
909 closureDescription mod_name name args body
910 = uppShow 0 (prettyToUn (
911 ppBesides [ppChar '<',
919 chooseDynCostCentres cc args fvs body
921 use_cc -- cost-centre we record in the object
922 = if currentOrSubsumedCosts cc
923 then CReg CurCostCentre
924 else mkCCostCentre cc
926 blame_cc -- cost-centre on whom we blame the allocation
927 = case (args, fvs, body) of
928 ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
930 -> mkCCostCentre overheadCostCentre
932 -- if it's an utterly trivial RHS, then it must be
933 -- one introduced by boxHigherOrderArgs for profiling,
934 -- so we charge it to "OVERHEAD".