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"
14 cgTopRhsClosure, cgRhsClosure,
16 -- and to make the interface self-sufficient...
17 StgExpr, Id, CgState, Maybe, HeapOffset,
18 CgInfoDownwards, CgIdInfo, CompilationInfo,
22 IMPORT_Trace -- ToDo: rm (debugging)
24 import Pretty -- NB: see below
30 import AbsPrel ( PrimOp(..), primOpNameInfo, Name
31 IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
32 IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
34 import AbsUniType ( isPrimType, isPrimTyCon,
35 getTauType, showTypeCategory, getTyConDataCons
36 IF_ATTACK_PRAGMAS(COMMA splitType)
37 IF_ATTACK_PRAGMAS(COMMA splitTyArgs)
39 import CgBindery ( getCAddrMode, getAtomAmodes,
41 bindNewToNode, bindNewToAStack, bindNewToBStack,
42 bindNewToReg, bindArgsToRegs
44 import CgCompInfo ( spARelToInt, spBRelToInt )
45 import CgExpr ( cgExpr, cgSccExpr )
46 import CgUpdate ( pushUpdateFrame )
47 import CgHeapery ( allocDynClosure, heapCheck
49 , heapCheckOnly, fetchAndReschedule -- HWL
52 import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
53 CtrlReturnConvention(..), DataReturnConvention(..)
55 import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
58 import CgUsages ( getVirtSps, setRealAndVirtualSps,
59 getSpARelOffset, getSpBRelOffset,
63 import ClosureInfo -- lots and lots of stuff
64 import CmdLineOpts ( GlobalSwitch(..) )
66 import Id ( getIdUniType, getIdKind, isSysLocalId, myWrapperMaybe,
67 showId, getIdInfo, getIdStrictness,
71 import ListSetOps ( minusList )
72 import Maybes ( Maybe(..), maybeToBool )
73 import PrimKind ( isFollowableKind )
79 %********************************************************
81 \subsection[closures-no-free-vars]{Top-level closures}
83 %********************************************************
85 For closures bound at top level, allocate in static space.
86 They should have no free variables.
90 -> CostCentre -- Optional cost centre annotation
95 -> FCode (Id, CgIdInfo)
100 cgTopRhsClosure name cc binder_info args body lf_info
101 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
103 -- LAY OUT THE OBJECT
104 getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
106 (closure_info, amodes_w_offsets) = layOutStaticClosure name getAmodeKind amodes lf_info
110 chooseStaticCostCentre cc lf_info `thenFC` \ cost_centre ->
112 closure_label -- Labelled with the name on lhs of defn
115 (map fst amodes_w_offsets)) -- They are in the correct order
118 returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info)
120 maybe_std_thunk = getStandardFormThunkInfo lf_info
121 Just std_thunk_payload = maybe_std_thunk
123 closure_label = mkClosureLabel name
129 cgTopRhsClosure name cc binder_info args body lf_info
130 = -- LAY OUT THE OBJECT
132 closure_info = layOutStaticNoFVClosure name lf_info
135 -- GENERATE THE INFO TABLE (IF NECESSARY)
136 forkClosureBody (closureCodeBody binder_info closure_info
140 -- BUILD VAP INFO TABLES IF NECESSARY
141 -- Don't build Vap info tables etc for
142 -- a function whose result is an unboxed type,
143 -- because we can never have thunks with such a type.
144 (if closureReturnsUnboxedType closure_info then
148 bind_the_fun = addBindC name cg_id_info -- It's global!
150 cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
153 -- BUILD THE OBJECT (IF NECESSARY)
154 (if staticClosureRequired name binder_info lf_info
157 cost_centre = mkCCostCentre cc
160 closure_label -- Labelled with the name on lhs of defn
168 returnFC (name, cg_id_info)
170 closure_label = mkClosureLabel name
171 cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrKind) lf_info
174 %********************************************************
176 \subsection[non-top-level-closures]{Non top-level closures}
178 %********************************************************
180 For closures with free vars, allocate in heap.
182 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
184 -- Closures which (a) have no fvs and (b) have some args (i.e.
185 -- combinator functions), are allocated statically, just as if they
186 -- were top-level closures. We can't get a space leak that way
187 -- (because they are HNFs) and it saves allocation.
189 -- Lexical Scoping: Problem
190 -- These top level function closures will be inherited, possibly
191 -- to a different cost centre scope set before entering.
193 -- Evaluation Scoping: ok as already in HNF
195 -- Should rely on floating mechanism to achieve this floating to top level.
196 -- As let floating will avoid floating which breaks cost centre attribution
197 -- everything will be OK.
199 -- Disabled: because it breaks lexical-scoped cost centre semantics.
200 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
201 -- = cgTopRhsClosure binder cc bi upd_flag args body
203 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
207 -> CostCentre -- Optional cost centre annotation
213 -> FCode (Id, CgIdInfo)
215 cgRhsClosure binder cc binder_info fvs args body lf_info
216 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
217 -- ToDo: check non-primitiveness (ASSERT)
219 -- LAY OUT THE OBJECT
220 getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
222 (closure_info, amodes_w_offsets)
223 = layOutDynClosure binder getAmodeKind amodes lf_info
225 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
228 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
230 `thenFC` \ heap_offset ->
233 returnFC (binder, heapIdInfo binder heap_offset lf_info)
236 maybe_std_thunk = getStandardFormThunkInfo lf_info
237 Just std_thunk_payload = maybe_std_thunk
240 Here's the general case.
242 cgRhsClosure binder cc binder_info fvs args body lf_info
244 -- LAY OUT THE OBJECT
246 -- If the binder is itself a free variable, then don't store
247 -- it in the closure. Instead, just bind it to Node on entry.
248 -- NB we can be sure that Node will point to it, because we
249 -- havn't told mkClosureLFInfo about this; so if the binder
250 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
251 -- stored in the closure itself, so it will make sure that
252 -- Node points to it...
254 is_elem = isIn "cgRhsClosure"
256 binder_is_a_fv = binder `is_elem` fvs
257 reduced_fvs = if binder_is_a_fv
258 then fvs `minusList` [binder]
261 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
263 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
265 closure_info :: ClosureInfo
266 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
268 (closure_info, bind_details)
269 = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
271 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
273 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
275 get_kind (id, amode_and_info) = getIdKind id
277 -- BUILD ITS INFO TABLE AND CODE
280 mapCs bind_fv bind_details `thenC`
282 -- Bind the binder itself, if it is a free var
283 (if binder_is_a_fv then
284 bindNewToReg binder node lf_info
289 closureCodeBody binder_info closure_info cc args body
292 -- BUILD VAP INFO TABLES IF NECESSARY
293 -- Don't build Vap info tables etc for
294 -- a function whose result is an unboxed type,
295 -- because we can never have thunks with such a type.
296 (if closureReturnsUnboxedType closure_info then
299 cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
304 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
306 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
307 ) `thenFC` \ heap_offset ->
310 returnFC (binder, heapIdInfo binder heap_offset lf_info)
313 @cgVapInfoTables@ generates both Vap info tables, if they are required
314 at all. It calls @cgVapInfoTable@ to generate each Vap info table,
315 along with its entry code.
318 -- Don't generate Vap info tables for thunks; only for functions
319 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
322 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
323 = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
324 (if stdVapRequired binder_info then
325 cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
330 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
331 (if noUpdVapRequired binder_info then
332 cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
338 fun_in_payload = not top_level
340 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
342 -- The vap_entry_rhs is a manufactured STG expression which
343 -- looks like the RHS of any binding which is going to use the vap-entry
344 -- point of the function. Each of these bindings will look like:
346 -- x = [a,b,c] \upd [] -> f a b c
348 -- If f is not top-level, then f is one of the free variables too,
349 -- hence "payload_ids" isn't the same as "arg_ids".
351 vap_entry_rhs = StgApp (StgVarAtom fun) (map StgVarAtom args) emptyUniqSet
354 arg_ids_w_info = [(name,mkLFArgument) | name <- args]
355 payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
356 | otherwise = arg_ids_w_info
358 payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
361 vap_lf_info = mkClosureLFInfo False {-not top level-} payload_ids
362 upd_flag [] vap_entry_rhs
363 -- It's not top level, even if we're currently compiling a top-level
364 -- function, because any VAP *use* of this function will be for a
366 -- let x = f p q -- x isn't top level!
369 get_kind (id, info) = getIdKind id
371 payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
372 (closure_info, payload_bind_details) = layOutDynClosure
374 get_kind payload_ids_w_info
376 -- The dodgy thing is that we use the "fun" as the
377 -- Id to give to layOutDynClosure. This Id gets embedded in
378 -- the closure_info it returns. But of course, the function doesn't
379 -- have the right type to match the Vap closure. Never mind,
380 -- a hack in closureType spots the special case. Otherwise that
381 -- Id is just used for label construction, which is OK.
383 bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
386 -- BUILD ITS INFO TABLE AND CODE
389 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
390 -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
391 perhaps_bind_the_fun `thenC`
392 mapCs bind_fv payload_bind_details `thenC`
394 -- Generate the info table and code
395 closureCodeBody NoStgBinderInfo
398 [] -- No args; it's a thunk
402 %************************************************************************
404 \subsection[code-for-closures]{The code for closures}
406 %************************************************************************
409 closureCodeBody :: StgBinderInfo
410 -> ClosureInfo -- Lots of information about this closure
411 -> CostCentre -- Optional cost centre attached to closure
417 There are two main cases for the code for closures. If there are {\em
418 no arguments}, then the closure is a thunk, and not in normal form.
419 So it should set up an update frame (if it is shared). Also, it has
420 no argument satisfaction check, so fast and slow entry-point labels
424 closureCodeBody binder_info closure_info cc [] body
425 = -- thunks cannot have a primitive type!
429 = case (closureType closure_info) of
430 Nothing -> (False, panic "debug")
431 Just (tc,_,_) -> (True, tc)
433 if has_tycon && isPrimTyCon tycon then
434 pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
437 getAbsC body_code `thenFC` \ body_absC ->
439 moduleName `thenFC` \ mod_name ->
440 absC (CClosureInfoAndCode closure_info body_absC Nothing stdUpd (cl_descr mod_name))
442 -- Applying a similar scheme to Simon's placing info tables before code...
444 absC (CNativeInfoTableAndCode closure_info
446 (CCodeBlock entry_label body_absC))
447 #endif {- Data Parallel Haskell -}
449 cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
451 body_addr = CLbl (entryLabelFromCI closure_info) CodePtrKind
452 body_code = profCtrC SLIT("ENT_THK") [] `thenC`
453 enterCostCentreCode closure_info cc IsThunk `thenC`
454 thunkWrapper closure_info (cgSccExpr body)
456 stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
459 If there is {\em at least one argument}, then this closure is in
460 normal form, so there is no need to set up an update frame. On the
461 other hand, we do have to check that there are enough args, and
462 perform an update if not!
464 The Macros for GrAnSim are produced at the beginning of the
465 argSatisfactionCheck (by calling fetchAndReschedule). There info if
466 Node points to closure is available. -- HWL
469 closureCodeBody binder_info closure_info cc all_args body
470 = getEntryConvention id lf_info
471 (map getIdKind all_args) `thenFC` \ entry_conv ->
473 isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
475 isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
477 isStringSwitchSetC AsmTarget `thenFC` \ native_code ->
480 stg_arity = length all_args
482 -- Arg mapping for standard (slow) entry point; all args on stack
483 (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
485 0 0 -- Initial virtual SpA, SpB
489 -- Arg mapping for the fast entry point; as many args as poss in
490 -- registers; the rest on the stack
491 -- arg_regs are the registers used for arg passing
492 -- stk_args are the args which are passed on the stack
494 arg_regs = case entry_conv of
495 DirectEntry lbl arity regs -> regs
496 ViaNode | is_concurrent -> []
497 other -> panic "closureCodeBody:arg_regs"
499 stk_args = drop (length arg_regs) all_args
500 (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
502 0 0 -- Initial virtual SpA, SpB
506 -- HWL; Note: empty list of live regs in slow entry code
507 -- Old version (reschedule combined with heap check);
508 -- see argSatisfactionCheck for new version
509 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
510 -- where node = VanillaReg PtrKind 1
511 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
514 = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
516 -- Bind args, and record expected position of stk ptrs
517 mapCs bindNewToAStack all_bxd_w_offsets `thenC`
518 mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
519 setRealAndVirtualSps spA_all_args spB_all_args `thenC`
521 argSatisfactionCheck closure_info all_args `thenC`
523 -- OK, so there are enough args. Now we need to stuff as
524 -- many of them in registers as the fast-entry code expects
525 -- Note that the zipWith will give up when it hits the end of arg_regs
526 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
527 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
529 -- Now adjust real stack pointers
530 adjustRealSps spA_stk_args spB_stk_args `thenC`
532 -- set the arity checker, if asked
535 then CMacroStmt SET_ARITY [mkIntCLit stg_arity]
540 absC (CFallThrough (CLbl fast_label CodePtrKind))
542 -- Fall through to the fast entry point
544 #endif {- Data Parallel Haskell -}
546 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
549 -- Old version (reschedule combined with heap check);
550 -- see argSatisfactionCheck for new version
551 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
554 = profCtrC SLIT("ENT_FUN_DIRECT") [
555 CLbl (mkRednCountsLabel id) PtrKind,
556 CString (_PK_ (showId PprDebug id)),
557 mkIntCLit stg_arity, -- total # of args
558 mkIntCLit spA_stk_args, -- # passed on A stk
559 mkIntCLit spB_stk_args, -- B stk (rest in regs)
560 CString (_PK_ (map (showTypeCategory . getIdUniType) all_args)),
561 CString (_PK_ (show_wrapper_name wrapper_maybe)),
562 CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
566 then CMacroStmt CHK_ARITY [mkIntCLit stg_arity]
570 -- Bind args to regs/stack as appropriate, and
571 -- record expected position of sps
572 bindArgsToRegs all_args arg_regs `thenC`
573 mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
574 mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
575 setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
577 -- Enter the closures cc, if required
578 enterCostCentreCode closure_info cc IsFunction `thenC`
581 funWrapper closure_info arg_regs (cgExpr body)
584 -- Make a labelled code-block for the slow and fast entry code
585 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
586 `thenFC` \ slow_abs_c ->
587 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
588 moduleName `thenFC` \ mod_name ->
589 -- Now either construct the info table, or put the fast code in alone
590 -- (We never have slow code without an info table)
594 CClosureInfoAndCode closure_info slow_abs_c
595 (Just fast_abs_c) stdUpd (cl_descr mod_name)
597 CCodeBlock fast_label fast_abs_c
602 -- The info table goes before the slow entry point.
603 forkAbsC slow_entry_code `thenFC` \ slow_abs_c ->
604 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
605 moduleName `thenFC` \ mod_name ->
606 absC (CNativeInfoTableAndCode
608 (closureDescription mod_name id all_args body)
609 (CCodeBlock slow_label
610 (AbsCStmts slow_abs_c
611 (CCodeBlock fast_label
614 slow_label = if slow_code_needed then
618 -- We may need a pointer to stuff in the info table,
619 -- but if the slow entry code isn't needed, this code
620 -- will never be entered, so we can use a standard
623 #endif {- Data Parallel Haskell -}
625 lf_info = closureLFInfo closure_info
627 cl_descr mod_name = closureDescription mod_name id all_args body
629 -- Figure out what is needed and what isn't
630 slow_code_needed = slowFunEntryCodeRequired id binder_info
631 info_table_needed = funInfoTableRequired id binder_info lf_info
633 -- Manufacture labels
634 id = closureId closure_info
636 fast_label = fastLabelFromCI closure_info
638 stdUpd = CLbl mkErrorStdEntryLabel CodePtrKind
640 wrapper_maybe = get_ultimate_wrapper Nothing id
642 get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
643 = case (myWrapperMaybe x) of
645 Just xx -> get_ultimate_wrapper (Just xx) xx
647 show_wrapper_name Nothing = ""
648 show_wrapper_name (Just xx) = showId PprDebug xx
650 show_wrapper_arg_kinds Nothing = ""
651 show_wrapper_arg_kinds (Just xx)
652 = case (getWrapperArgTypeCategories (getIdUniType xx) (getIdStrictness xx)) of
657 For lexically scoped profiling we have to load the cost centre from
658 the closure entered, if the costs are not supposed to be inherited.
659 This is done immediately on entering the fast entry point.
661 Load current cost centre from closure, if not inherited.
662 Node is guaranteed to point to it, if profiling and not inherited.
665 data IsThunk = IsThunk | IsFunction -- Bool-like, local
667 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
669 enterCostCentreCode closure_info cc is_thunk
670 = costCentresFlag `thenFC` \ profiling_on ->
671 if not profiling_on then
673 else -- down to business
674 ASSERT(not (noCostCentreAttached cc))
676 if costsAreSubsumed cc then
679 else if is_current_CC cc then -- fish the CC out of the closure,
680 -- where we put it when we alloc'd;
681 -- NB: chk defn of "is_current_CC"
682 -- if you go to change this! (WDP 94/12)
685 IsThunk -> SLIT("ENTER_CC_TCL")
686 IsFunction -> SLIT("ENTER_CC_FCL"))
689 else if isCafCC cc then
694 else -- we've got a "real" cost centre right here in our hands...
697 IsThunk -> SLIT("ENTER_CC_T")
698 IsFunction -> SLIT("ENTER_CC_F"))
702 = currentOrSubsumedCosts cc
703 -- but we've already ruled out "subsumed", so it must be "current"!
706 %************************************************************************
708 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
710 %************************************************************************
712 The argument-satisfaction check code is placed after binding
713 the arguments to their stack locations. Hence, the virtual stack
714 pointer is pointing after all the args, and virtual offset 1 means
715 the base of frame and hence most distant arg. Hence
716 virtual offset 0 is just beyond the most distant argument; the
717 relative offset of this word tells how many words of arguments
721 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
723 argSatisfactionCheck closure_info [] = nopC
725 argSatisfactionCheck closure_info args
726 = -- safest way to determine which stack last arg will be on:
727 -- look up CAddrMode that last arg is bound to;
729 -- check isFollowableKind.
731 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
735 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
736 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
738 then fetchAndReschedule [] node_points
739 else absC AbsCNop) `thenC`
742 getCAddrMode (last args) `thenFC` \ last_amode ->
744 if (isFollowableKind (getAmodeKind last_amode)) then
745 getSpARelOffset 0 `thenFC` \ a_rel_offset ->
747 absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt a_rel_offset)])
749 absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
750 [mkIntCLit (spARelToInt a_rel_offset), set_Node_to_this])
752 getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
754 absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
756 absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
757 [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
759 -- We must tell the arg-satis macro whether Node is pointing to
760 -- the closure or not. If it isn't so pointing, then we give to
761 -- the macro the (static) address of the closure.
763 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrKind
766 %************************************************************************
768 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
770 %************************************************************************
773 thunkWrapper:: ClosureInfo -> Code -> Code
774 thunkWrapper closure_info thunk_code
775 = -- Stack and heap overflow checks
776 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
779 -- HWL insert macros for GrAnSim if node is live here
781 then fetchAndReschedule [] node_points
782 else absC AbsCNop) `thenC`
785 stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
787 -- Must be after stackCheck: if stchk fails new stack
788 -- space has to be allocated from the heap
790 heapCheck [] node_points (
791 -- heapCheck *encloses* the rest
792 -- The "[]" says there are no live argument registers
794 -- Overwrite with black hole if necessary
795 blackHoleIt closure_info `thenC`
797 -- Push update frame if necessary
798 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
800 -- Evaluation scoping -- load current cost centre from closure
801 -- Must be done after the update frame is pushed
802 -- Node is guaranteed to point to it, if profiling
804 -- (if isStaticClosure closure_info
805 -- then evalCostCentreC "SET_CAFCC_CL" [CReg node]
806 -- else evalCostCentreC "ENTER_CC_TCL" [CReg node]) `thenC`
808 -- Finally, do the business
812 funWrapper :: ClosureInfo -- Closure whose code body this is
813 -> [MagicId] -- List of argument registers (if any)
814 -> Code -- Body of function being compiled
816 funWrapper closure_info arg_regs fun_body
817 = -- Stack overflow check
818 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
819 stackCheck closure_info arg_regs node_points ( -- stackCheck *encloses* the rest
821 -- Heap overflow check
822 heapCheck arg_regs node_points (
823 -- heapCheck *encloses* the rest
825 -- Finally, do the business
830 %************************************************************************
832 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
834 %************************************************************************
836 Assumption: virtual and real stack pointers are currently exactly aligned.
839 stackCheck :: ClosureInfo
840 -> [MagicId] -- Live registers
841 -> Bool -- Node required to point after check?
845 stackCheck closure_info regs node_reqd code
846 = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
848 getVirtSps `thenFC` \ (vSpA, vSpB) ->
850 let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
851 b_headroom_reqd = bHw - vSpB
854 absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
857 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
858 mkIntCLit a_headroom_reqd,
859 mkIntCLit b_headroom_reqd,
862 mkIntCLit (if returns_prim_type then 1 else 0),
863 mkIntCLit (if node_reqd then 1 else 0)]
865 -- The test is *inside* the absC, to avoid black holes!
870 all_regs = if node_reqd then node:regs else regs
871 liveness_mask = mkLiveRegsBitMask all_regs
873 returns_prim_type = closureReturnsUnboxedType closure_info
876 %************************************************************************
878 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
880 %************************************************************************
884 blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
885 blackHoleIt closure_info
886 = noBlackHolingFlag `thenFC` \ no_black_holing ->
888 if (blackHoleOnEntry no_black_holing closure_info)
890 absC (if closureSingleEntry(closure_info) then
891 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
893 CMacroStmt UPD_BH_UPDATABLE [CReg node])
894 -- Node always points to it; see stg-details
900 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
901 -- Nota Bene: this function does not change Node (even if it's a CAF),
902 -- so that the cost centre in the original closure can still be
903 -- extracted by a subsequent ENTER_CC_TCL
905 setupUpdate closure_info code
906 = if (closureUpdReqd closure_info) then
907 link_caf_if_needed `thenFC` \ update_closure ->
908 pushUpdateFrame update_closure vector code
910 -- Non-updatable thunks still need a resume-cost-centre "update"
911 -- frame to be pushed if we are doing evaluation profiling.
913 --OLD: evalPushRCCFrame False {-never primitive-} (
914 profCtrC SLIT("UPDF_OMITTED") []
919 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
921 = if not (isStaticClosure closure_info) then
925 -- First we must allocate a black hole, and link the
926 -- CAF onto the CAF list
928 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
929 -- Hack Warning: Using a CLitLit to get CAddrMode !
931 use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrKind
934 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
935 `thenFC` \ heap_offset ->
936 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
937 let amode = CAddr hp_rel
939 absC (CMacroStmt UPD_CAF [CReg node, amode])
943 closure_label = mkClosureLabel (closureId closure_info)
945 vector = case (closureType closure_info) of
946 Nothing -> CReg StdUpdRetVecReg
947 Just (spec_tycon, _, spec_datacons) ->
948 case ctrlReturnConvAlg spec_tycon of
949 UnvectoredReturn 1 ->
951 spec_data_con = head spec_datacons
952 only_tag = getDataConTag spec_data_con
953 direct = case dataReturnConvAlg spec_data_con of
954 ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
955 ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
956 vectored = mkStdUpdVecTblLabel spec_tycon
958 CUnVecLbl direct vectored
960 UnvectoredReturn _ -> CReg StdUpdRetVecReg
961 VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrKind
964 %************************************************************************
966 \subsection[CgClosure-Description]{Profiling Closure Description.}
968 %************************************************************************
970 For "global" data constructors the description is simply occurrence
971 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
973 Otherwise it is determind by @closureDescription@ from the let
977 closureDescription :: FAST_STRING -- Module
978 -> Id -- Id of closure binding
980 -> PlainStgExpr -- Body
983 -- Not called for StgRhsCon which have global info tables built in
984 -- CgConTbls.lhs with a description generated from the data constructor
986 closureDescription mod_name name args body =
987 uppShow 0 (prettyToUn (
988 ppBesides [ppChar '<',
996 chooseDynCostCentres cc args fvs body
998 use_cc -- cost-centre we record in the object
999 = if currentOrSubsumedCosts cc
1000 then CReg CurCostCentre
1001 else mkCCostCentre cc
1003 blame_cc -- cost-centre on whom we blame the allocation
1004 = case (args, fvs, body) of
1005 ([], [just1], StgApp (StgVarAtom fun) [{-no args-}] _)
1007 -> mkCCostCentre overheadCostCentre
1009 -- if it's an utterly trivial RHS, then it must be
1010 -- one introduced by boxHigherOrderArgs for profiling,
1011 -- so we charge it to "OVERHEAD".