2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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_DELOOPER(CgLoop2) ( cgExpr )
22 import AbsCUtils ( mkAbstractCs, getAmodeRep )
23 import CgBindery ( getCAddrMode, getArgAmodes,
24 getCAddrModeAndInfo, bindNewToNode,
25 bindNewToAStack, bindNewToBStack,
26 bindNewToReg, bindArgsToRegs,
27 stableAmodeIdInfo, heapIdInfo, CgIdInfo
29 import Constants ( spARelToInt, spBRelToInt )
30 import CgUpdate ( pushUpdateFrame )
31 import CgHeapery ( allocDynClosure, heapCheck
32 , heapCheckOnly, fetchAndReschedule, yield -- HWL
34 import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg,
35 CtrlReturnConvention(..), DataReturnConvention(..)
37 import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
40 import CgUsages ( getVirtSps, setRealAndVirtualSps,
41 getSpARelOffset, getSpBRelOffset,
44 import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel, mkFastEntryLabel,
45 mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
46 mkErrorStdEntryLabel, mkRednCountsLabel
48 import ClosureInfo -- lots and lots of stuff
49 import CmdLineOpts ( opt_ForConcurrent, opt_GranMacros )
50 import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
51 noCostCentreAttached, costsAreSubsumed,
52 isCafCC, isDictCC, overheadCostCentre, showCostCentre
54 import HeapOffs ( SYN_IE(VirtualHeapOffset) )
55 import Id ( idType, idPrimRep,
56 showId, getIdStrictness, dataConTag,
58 GenId{-instance Outputable-}
60 import ListSetOps ( minusList )
61 import Maybes ( maybeToBool )
62 import Outputable ( Outputable(..){-instances-} ) -- ToDo:rm
63 import PprStyle ( PprStyle(..) )
64 import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
65 import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
66 import PrimRep ( isFollowableRep, PrimRep(..) )
67 import TyCon ( isPrimTyCon, tyConDataCons )
68 import Unpretty ( uppShow )
69 import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
71 myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
72 showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
73 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
76 %********************************************************
78 \subsection[closures-no-free-vars]{Top-level closures}
80 %********************************************************
82 For closures bound at top level, allocate in static space.
83 They should have no free variables.
87 -> CostCentre -- Optional cost centre annotation
92 -> FCode (Id, CgIdInfo)
94 cgTopRhsClosure name cc binder_info args body lf_info
95 = -- LAY OUT THE OBJECT
97 closure_info = layOutStaticNoFVClosure name lf_info
100 -- GENERATE THE INFO TABLE (IF NECESSARY)
101 forkClosureBody (closureCodeBody binder_info closure_info
105 -- BUILD VAP INFO TABLES IF NECESSARY
106 -- Don't build Vap info tables etc for
107 -- a function whose result is an unboxed type,
108 -- because we can never have thunks with such a type.
109 (if closureReturnsUnboxedType closure_info then
113 bind_the_fun = addBindC name cg_id_info -- It's global!
115 cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
118 -- BUILD THE OBJECT (IF NECESSARY)
119 (if staticClosureRequired name binder_info lf_info
122 cost_centre = mkCCostCentre cc
125 closure_label -- Labelled with the name on lhs of defn
133 returnFC (name, cg_id_info)
135 closure_label = mkClosureLabel name
136 cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
139 %********************************************************
141 \subsection[non-top-level-closures]{Non top-level closures}
143 %********************************************************
145 For closures with free vars, allocate in heap.
147 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
149 -- Closures which (a) have no fvs and (b) have some args (i.e.
150 -- combinator functions), are allocated statically, just as if they
151 -- were top-level closures. We can't get a space leak that way
152 -- (because they are HNFs) and it saves allocation.
154 -- Lexical Scoping: Problem
155 -- These top level function closures will be inherited, possibly
156 -- to a different cost centre scope set before entering.
158 -- Evaluation Scoping: ok as already in HNF
160 -- Should rely on floating mechanism to achieve this floating to top level.
161 -- As let floating will avoid floating which breaks cost centre attribution
162 -- everything will be OK.
164 -- Disabled: because it breaks lexical-scoped cost centre semantics.
165 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
166 -- = cgTopRhsClosure binder cc bi upd_flag args body
168 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
172 -> CostCentre -- Optional cost centre annotation
178 -> FCode (Id, CgIdInfo)
180 cgRhsClosure binder cc binder_info fvs args body lf_info
181 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
182 -- ToDo: check non-primitiveness (ASSERT)
184 -- LAY OUT THE OBJECT
185 getArgAmodes std_thunk_payload `thenFC` \ amodes ->
187 (closure_info, amodes_w_offsets)
188 = layOutDynClosure binder getAmodeRep amodes lf_info
190 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
193 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
195 `thenFC` \ heap_offset ->
198 returnFC (binder, heapIdInfo binder heap_offset lf_info)
201 maybe_std_thunk = getStandardFormThunkInfo lf_info
202 Just std_thunk_payload = maybe_std_thunk
205 Here's the general case.
207 cgRhsClosure binder cc binder_info fvs args body lf_info
209 -- LAY OUT THE OBJECT
211 -- If the binder is itself a free variable, then don't store
212 -- it in the closure. Instead, just bind it to Node on entry.
213 -- NB we can be sure that Node will point to it, because we
214 -- havn't told mkClosureLFInfo about this; so if the binder
215 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
216 -- stored in the closure itself, so it will make sure that
217 -- Node points to it...
219 is_elem = isIn "cgRhsClosure"
221 binder_is_a_fv = binder `is_elem` fvs
222 reduced_fvs = if binder_is_a_fv
223 then fvs `minusList` [binder]
226 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
228 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
230 closure_info :: ClosureInfo
231 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
233 (closure_info, bind_details)
234 = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
236 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
238 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
240 get_kind (id, amode_and_info) = idPrimRep id
242 -- BUILD ITS INFO TABLE AND CODE
245 mapCs bind_fv bind_details `thenC`
247 -- Bind the binder itself, if it is a free var
248 (if binder_is_a_fv then
249 bindNewToReg binder node lf_info
254 closureCodeBody binder_info closure_info cc args body
257 -- BUILD VAP INFO TABLES IF NECESSARY
258 -- Don't build Vap info tables etc for
259 -- a function whose result is an unboxed type,
260 -- because we can never have thunks with such a type.
261 (if closureReturnsUnboxedType closure_info then
264 cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
269 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
271 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
272 ) `thenFC` \ heap_offset ->
275 returnFC (binder, heapIdInfo binder heap_offset lf_info)
278 @cgVapInfoTables@ generates both Vap info tables, if they are required
279 at all. It calls @cgVapInfoTable@ to generate each Vap info table,
280 along with its entry code.
283 -- Don't generate Vap info tables for thunks; only for functions
284 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
287 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
288 = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
289 (if stdVapRequired binder_info then
290 cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
295 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
296 (if noUpdVapRequired binder_info then
297 cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
303 fun_in_payload = not top_level
305 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
307 -- The vap_entry_rhs is a manufactured STG expression which
308 -- looks like the RHS of any binding which is going to use the vap-entry
309 -- point of the function. Each of these bindings will look like:
311 -- x = [a,b,c] \upd [] -> f a b c
313 -- If f is not top-level, then f is one of the free variables too,
314 -- hence "payload_ids" isn't the same as "arg_ids".
316 stg_args = map StgVarArg args
317 vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
320 arg_ids_w_info = [(name,mkLFArgument) | name <- args]
321 payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
322 | otherwise = arg_ids_w_info
324 payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
327 vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
328 -- It's not top level, even if we're currently compiling a top-level
329 -- function, because any VAP *use* of this function will be for a
331 -- let x = f p q -- x isn't top level!
334 get_kind (id, info) = idPrimRep id
336 payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
337 (closure_info, payload_bind_details) = layOutDynClosure
339 get_kind payload_ids_w_info
341 -- The dodgy thing is that we use the "fun" as the
342 -- Id to give to layOutDynClosure. This Id gets embedded in
343 -- the closure_info it returns. But of course, the function doesn't
344 -- have the right type to match the Vap closure. Never mind,
345 -- a hack in closureType spots the special case. Otherwise that
346 -- Id is just used for label construction, which is OK.
348 bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
351 -- BUILD ITS INFO TABLE AND CODE
354 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
355 -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
356 perhaps_bind_the_fun `thenC`
357 mapCs bind_fv payload_bind_details `thenC`
359 -- Generate the info table and code
360 closureCodeBody NoStgBinderInfo
363 [] -- No args; it's a thunk
367 %************************************************************************
369 \subsection[code-for-closures]{The code for closures}
371 %************************************************************************
374 closureCodeBody :: StgBinderInfo
375 -> ClosureInfo -- Lots of information about this closure
376 -> CostCentre -- Optional cost centre attached to closure
382 There are two main cases for the code for closures. If there are {\em
383 no arguments}, then the closure is a thunk, and not in normal form.
384 So it should set up an update frame (if it is shared). Also, it has
385 no argument satisfaction check, so fast and slow entry-point labels
389 closureCodeBody binder_info closure_info cc [] body
390 = -- thunks cannot have a primitive type!
394 = case (closureType closure_info) of
395 Nothing -> (False, panic "debug")
396 Just (tc,_,_) -> (True, tc)
398 if has_tycon && isPrimTyCon tycon then
399 pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
402 getAbsC body_code `thenFC` \ body_absC ->
403 moduleName `thenFC` \ mod_name ->
405 absC (CClosureInfoAndCode closure_info body_absC Nothing
406 stdUpd (cl_descr mod_name)
407 (dataConLiveness closure_info))
409 cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
411 body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
412 body_code = profCtrC SLIT("ENT_THK") [] `thenC`
413 thunkWrapper closure_info (
414 -- We only enter cc after setting up update so that cc
415 -- of enclosing scope will be recorded in update frame
416 -- CAF/DICT functions will be subsumed by this enclosing cc
417 enterCostCentreCode closure_info cc IsThunk `thenC`
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 -- Arg mapping for standard (slow) entry point; all args on stack
438 (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
440 0 0 -- Initial virtual SpA, SpB
444 -- Arg mapping for the fast entry point; as many args as poss in
445 -- registers; the rest on the stack
446 -- arg_regs are the registers used for arg passing
447 -- stk_args are the args which are passed on the stack
449 arg_regs = case entry_conv of
450 DirectEntry lbl arity regs -> regs
451 ViaNode | is_concurrent -> []
452 other -> panic "closureCodeBody:arg_regs"
454 num_arg_regs = length arg_regs
456 (reg_args, stk_args) = splitAt num_arg_regs all_args
458 (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
460 0 0 -- Initial virtual SpA, SpB
464 -- HWL; Note: empty list of live regs in slow entry code
465 -- Old version (reschedule combined with heap check);
466 -- see argSatisfactionCheck for new version
467 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
468 -- where node = VanillaReg PtrRep 1
469 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
472 = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
474 -- Bind args, and record expected position of stk ptrs
475 mapCs bindNewToAStack all_bxd_w_offsets `thenC`
476 mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
477 setRealAndVirtualSps spA_all_args spB_all_args `thenC`
479 argSatisfactionCheck closure_info all_args `thenC`
481 -- OK, so there are enough args. Now we need to stuff as
482 -- many of them in registers as the fast-entry code
483 -- expects Note that the zipWith will give up when it hits
484 -- the end of arg_regs.
486 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
487 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
489 -- Now adjust real stack pointers
490 adjustRealSps spA_stk_args spB_stk_args `thenC`
492 absC (CFallThrough (CLbl fast_label CodePtrRep))
494 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
497 -- Old version (reschedule combined with heap check);
498 -- see argSatisfactionCheck for new version
499 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
502 = profCtrC SLIT("ENT_FUN_DIRECT") [
503 CLbl (mkRednCountsLabel id) PtrRep,
504 CString (_PK_ (showId PprDebug id)),
505 mkIntCLit stg_arity, -- total # of args
506 mkIntCLit spA_stk_args, -- # passed on A stk
507 mkIntCLit spB_stk_args, -- B stk (rest in regs)
508 CString (_PK_ (map (showTypeCategory . idType) all_args)),
509 CString SLIT(""), CString SLIT("")
511 -- Nuked for now; see comment at end of file
512 -- CString (_PK_ (show_wrapper_name wrapper_maybe)),
513 -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
517 -- Bind args to regs/stack as appropriate, and
518 -- record expected position of sps
519 bindArgsToRegs reg_args arg_regs `thenC`
520 mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
521 mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
522 setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
524 -- Enter the closures cc, if required
525 enterCostCentreCode closure_info cc IsFunction `thenC`
528 funWrapper closure_info arg_regs (cgExpr body)
530 -- Make a labelled code-block for the slow and fast entry code
531 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
532 `thenFC` \ slow_abs_c ->
533 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
534 moduleName `thenFC` \ mod_name ->
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 closure_info)
544 CCodeBlock fast_label fast_abs_c
547 is_concurrent = opt_ForConcurrent
548 stg_arity = length all_args
549 lf_info = closureLFInfo closure_info
551 cl_descr mod_name = closureDescription mod_name id all_args body
553 -- Figure out what is needed and what isn't
554 slow_code_needed = slowFunEntryCodeRequired id binder_info
555 info_table_needed = funInfoTableRequired id binder_info lf_info
557 -- Manufacture labels
558 id = closureId closure_info
559 fast_label = mkFastEntryLabel id stg_arity
560 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
562 {- OLD... see note at end of file
563 wrapper_maybe = get_ultimate_wrapper Nothing id
565 get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
566 = case (myWrapperMaybe x) of
568 Just xx -> get_ultimate_wrapper (Just xx) xx
570 show_wrapper_name Nothing = ""
571 show_wrapper_name (Just xx) = showId PprDebug xx
573 show_wrapper_arg_kinds Nothing = ""
574 show_wrapper_arg_kinds (Just xx)
575 = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
581 For lexically scoped profiling we have to load the cost centre from
582 the closure entered, if the costs are not supposed to be inherited.
583 This is done immediately on entering the fast entry point.
585 Load current cost centre from closure, if not inherited.
586 Node is guaranteed to point to it, if profiling and not inherited.
589 data IsThunk = IsThunk | IsFunction -- Bool-like, local
594 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
596 enterCostCentreCode closure_info cc is_thunk
597 = costCentresFlag `thenFC` \ profiling_on ->
598 if not profiling_on then
601 ASSERT(not (noCostCentreAttached cc))
603 if costsAreSubsumed cc then
604 --ASSERT(isToplevClosure closure_info)
605 --ASSERT(is_thunk == IsFunction)
606 (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
607 costCentresC SLIT("ENTER_CC_FSUB") []
609 else if currentOrSubsumedCosts cc then
610 -- i.e. current; subsumed dealt with above
611 -- get CCC out of the closure, where we put it when we alloc'd
613 IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
614 IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
616 else if isCafCC cc && isToplevClosure closure_info then
617 ASSERT(is_thunk == IsThunk)
618 costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
620 else -- we've got a "real" cost centre right here in our hands...
622 IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
623 IsFunction -> if isCafCC cc || isDictCC cc
624 then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
625 else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
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 ->
656 emit_gran_macros = opt_GranMacros
660 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
661 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
664 then fetchAndReschedule [] node_points
665 else yield [] node_points
666 else absC AbsCNop) `thenC`
668 getCAddrMode (last args) `thenFC` \ last_amode ->
670 if (isFollowableRep (getAmodeRep last_amode)) then
671 getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
673 a_rel_int = spARelToInt spA off
674 a_rel_arg = mkIntCLit a_rel_int
676 ASSERT(a_rel_int /= 0)
678 absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
680 absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
682 getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
684 b_rel_int = spBRelToInt spB off
685 b_rel_arg = mkIntCLit b_rel_int
687 ASSERT(b_rel_int /= 0)
689 absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
691 absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
693 -- We must tell the arg-satis macro whether Node is pointing to
694 -- the closure or not. If it isn't so pointing, then we give to
695 -- the macro the (static) address of the closure.
697 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
700 %************************************************************************
702 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
704 %************************************************************************
707 thunkWrapper:: ClosureInfo -> Code -> Code
708 thunkWrapper closure_info thunk_code
709 = -- Stack and heap overflow checks
710 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
713 emit_gran_macros = opt_GranMacros
715 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
716 -- (we prefer fetchAndReschedule-style context switches to yield ones)
719 then fetchAndReschedule [] node_points
720 else yield [] node_points
721 else absC AbsCNop) `thenC`
723 stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
725 -- heapCheck must be after stackCheck: if stchk fails
726 -- new stack space is allocated from the heap which
727 -- would violate any previous heapCheck
729 heapCheck [] node_points ( -- heapCheck *encloses* the rest
730 -- The "[]" says there are no live argument registers
732 -- Overwrite with black hole if necessary
733 blackHoleIt closure_info `thenC`
735 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
737 -- Finally, do the business
741 funWrapper :: ClosureInfo -- Closure whose code body this is
742 -> [MagicId] -- List of argument registers (if any)
743 -> Code -- Body of function being compiled
745 funWrapper closure_info arg_regs fun_body
746 = -- Stack overflow check
747 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
749 emit_gran_macros = opt_GranMacros
753 then yield arg_regs node_points
754 else absC AbsCNop) `thenC`
756 stackCheck closure_info arg_regs node_points (
757 -- stackCheck *encloses* the rest
759 heapCheck arg_regs node_points (
760 -- heapCheck *encloses* the rest
762 -- Finally, do the business
767 %************************************************************************
769 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
771 %************************************************************************
773 Assumption: virtual and real stack pointers are currently exactly aligned.
776 stackCheck :: ClosureInfo
777 -> [MagicId] -- Live registers
778 -> Bool -- Node required to point after check?
782 stackCheck closure_info regs node_reqd code
783 = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
785 getVirtSps `thenFC` \ (vSpA, vSpB) ->
787 let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
788 b_headroom_reqd = bHw - vSpB
791 absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
794 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
795 mkIntCLit a_headroom_reqd,
796 mkIntCLit b_headroom_reqd,
799 mkIntCLit (if returns_prim_type then 1 else 0),
800 mkIntCLit (if node_reqd then 1 else 0)]
802 -- The test is *inside* the absC, to avoid black holes!
807 all_regs = if node_reqd then node:regs else regs
808 liveness_mask = mkLiveRegsMask all_regs
810 returns_prim_type = closureReturnsUnboxedType closure_info
813 %************************************************************************
815 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
817 %************************************************************************
821 blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
822 blackHoleIt closure_info
823 = noBlackHolingFlag `thenFC` \ no_black_holing ->
825 if (blackHoleOnEntry no_black_holing closure_info)
827 absC (if closureSingleEntry(closure_info) then
828 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
830 CMacroStmt UPD_BH_UPDATABLE [CReg node])
831 -- Node always points to it; see stg-details
837 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
838 -- Nota Bene: this function does not change Node (even if it's a CAF),
839 -- so that the cost centre in the original closure can still be
840 -- extracted by a subsequent ENTER_CC_TCL
842 setupUpdate closure_info code
843 = if (closureUpdReqd closure_info) then
844 link_caf_if_needed `thenFC` \ update_closure ->
845 pushUpdateFrame update_closure vector code
847 profCtrC SLIT("UPDF_OMITTED") [] `thenC`
850 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
852 = if not (isStaticClosure closure_info) then
856 -- First we must allocate a black hole, and link the
857 -- CAF onto the CAF list
859 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
860 -- Hack Warning: Using a CLitLit to get CAddrMode !
862 use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
865 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
866 `thenFC` \ heap_offset ->
867 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
868 let amode = CAddr hp_rel
870 absC (CMacroStmt UPD_CAF [CReg node, amode])
875 = case (closureType closure_info) of
876 Nothing -> CReg StdUpdRetVecReg
877 Just (spec_tycon, _, spec_datacons) ->
878 case (ctrlReturnConvAlg spec_tycon) of
879 UnvectoredReturn 1 ->
881 spec_data_con = head spec_datacons
882 only_tag = dataConTag spec_data_con
884 direct = case (dataReturnConvAlg spec_data_con) of
885 ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
886 ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
888 vectored = mkStdUpdVecTblLabel spec_tycon
890 CUnVecLbl direct vectored
892 UnvectoredReturn _ -> CReg StdUpdRetVecReg
893 VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
896 %************************************************************************
898 \subsection[CgClosure-Description]{Profiling Closure Description.}
900 %************************************************************************
902 For "global" data constructors the description is simply occurrence
903 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
905 Otherwise it is determind by @closureDescription@ from the let
909 closureDescription :: FAST_STRING -- Module
910 -> Id -- Id of closure binding
915 -- Not called for StgRhsCon which have global info tables built in
916 -- CgConTbls.lhs with a description generated from the data constructor
918 closureDescription mod_name name args body
919 = uppShow 0 (prettyToUn (
920 ppBesides [ppChar '<',
928 chooseDynCostCentres cc args fvs body
930 use_cc -- cost-centre we record in the object
931 = if currentOrSubsumedCosts cc
932 then CReg CurCostCentre
933 else mkCCostCentre cc
935 blame_cc -- cost-centre on whom we blame the allocation
936 = case (args, fvs, body) of
937 ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
939 -> mkCCostCentre overheadCostCentre
942 -- if it's an utterly trivial RHS, then it must be
943 -- one introduced by boxHigherOrderArgs for profiling,
944 -- so we charge it to "OVERHEAD".
951 ========================================================================
952 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
954 It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
957 getWrapperArgTypeCategories
958 :: Type -- wrapper's type
959 -> StrictnessInfo bdee -- strictness info about its args
962 getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
963 getWrapperArgTypeCategories _ BottomGuaranteed
964 = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
965 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
967 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
968 = Just (mkWrapperArgTypeCategories ty arg_info)
970 mkWrapperArgTypeCategories
971 :: Type -- wrapper's type
972 -> [Demand] -- info about its arguments
973 -> String -- a string saying lots about the args
975 mkWrapperArgTypeCategories wrapper_ty wrap_info
976 = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
977 map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
979 -- ToDo: this needs FIXING UP (it was a hack anyway...)
980 do_one (WwPrim, _) = 'P'
981 do_one (WwEnum, _) = 'E'
982 do_one (WwStrict, arg_ty_char) = arg_ty_char
983 do_one (WwUnpack _, arg_ty_char)
984 = if arg_ty_char `elem` "CIJFDTS"
985 then toLower arg_ty_char
986 else if arg_ty_char == '+' then 't'
987 else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
988 do_one (other_wrap_info, _) = '-'