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,
55 import HeapOffs ( SYN_IE(VirtualHeapOffset) )
56 import Id ( idType, idPrimRep,
57 showId, getIdStrictness, dataConTag,
59 GenId{-instance Outputable-}, SYN_IE(Id)
61 import ListSetOps ( minusList )
62 import Maybes ( maybeToBool )
63 import Outputable ( Outputable(..){-instances-}, PprStyle(..) )
64 import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
65 import Pretty ( Doc, hcat, char, ptext, hsep, text )
66 import PrimRep ( isFollowableRep, PrimRep(..) )
67 import TyCon ( isPrimTyCon, tyConDataCons )
68 import Type ( showTypeCategory )
69 import Util ( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
71 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
74 %********************************************************
76 \subsection[closures-no-free-vars]{Top-level closures}
78 %********************************************************
80 For closures bound at top level, allocate in static space.
81 They should have no free variables.
85 -> CostCentre -- Optional cost centre annotation
90 -> FCode (Id, CgIdInfo)
92 cgTopRhsClosure name cc binder_info args body lf_info
93 = -- LAY OUT THE OBJECT
95 closure_info = layOutStaticNoFVClosure name lf_info
98 -- GENERATE THE INFO TABLE (IF NECESSARY)
99 forkClosureBody (closureCodeBody binder_info closure_info
103 -- BUILD VAP INFO TABLES IF NECESSARY
104 -- Don't build Vap info tables etc for
105 -- a function whose result is an unboxed type,
106 -- because we can never have thunks with such a type.
107 (if closureReturnsUnboxedType closure_info then
111 bind_the_fun = addBindC name cg_id_info -- It's global!
113 cgVapInfoTables True {- Top level -} bind_the_fun binder_info name args lf_info
116 -- BUILD THE OBJECT (IF NECESSARY)
117 (if staticClosureRequired name binder_info lf_info
120 cost_centre = mkCCostCentre cc
123 closure_label -- Labelled with the name on lhs of defn
131 returnFC (name, cg_id_info)
133 closure_label = mkClosureLabel name
134 cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
137 %********************************************************
139 \subsection[non-top-level-closures]{Non top-level closures}
141 %********************************************************
143 For closures with free vars, allocate in heap.
145 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
147 -- Closures which (a) have no fvs and (b) have some args (i.e.
148 -- combinator functions), are allocated statically, just as if they
149 -- were top-level closures. We can't get a space leak that way
150 -- (because they are HNFs) and it saves allocation.
152 -- Lexical Scoping: Problem
153 -- These top level function closures will be inherited, possibly
154 -- to a different cost centre scope set before entering.
156 -- Evaluation Scoping: ok as already in HNF
158 -- Should rely on floating mechanism to achieve this floating to top level.
159 -- As let floating will avoid floating which breaks cost centre attribution
160 -- everything will be OK.
162 -- Disabled: because it breaks lexical-scoped cost centre semantics.
163 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
164 -- = cgTopRhsClosure binder cc bi upd_flag args body
166 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
170 -> CostCentre -- Optional cost centre annotation
176 -> FCode (Id, CgIdInfo)
178 cgRhsClosure binder cc binder_info fvs args body lf_info
179 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
180 -- ToDo: check non-primitiveness (ASSERT)
182 -- LAY OUT THE OBJECT
183 getArgAmodes std_thunk_payload `thenFC` \ amodes ->
185 (closure_info, amodes_w_offsets)
186 = layOutDynClosure binder getAmodeRep amodes lf_info
188 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
191 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
193 `thenFC` \ heap_offset ->
196 returnFC (binder, heapIdInfo binder heap_offset lf_info)
199 maybe_std_thunk = getStandardFormThunkInfo lf_info
200 Just std_thunk_payload = maybe_std_thunk
203 Here's the general case.
205 cgRhsClosure binder cc binder_info fvs args body lf_info
207 -- LAY OUT THE OBJECT
209 -- If the binder is itself a free variable, then don't store
210 -- it in the closure. Instead, just bind it to Node on entry.
211 -- NB we can be sure that Node will point to it, because we
212 -- havn't told mkClosureLFInfo about this; so if the binder
213 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
214 -- stored in the closure itself, so it will make sure that
215 -- Node points to it...
217 is_elem = isIn "cgRhsClosure"
219 binder_is_a_fv = binder `is_elem` fvs
220 reduced_fvs = if binder_is_a_fv
221 then fvs `minusList` [binder]
224 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
226 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
228 closure_info :: ClosureInfo
229 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
231 (closure_info, bind_details)
232 = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
234 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
236 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
238 get_kind (id, amode_and_info) = idPrimRep id
240 -- BUILD ITS INFO TABLE AND CODE
243 mapCs bind_fv bind_details `thenC`
245 -- Bind the binder itself, if it is a free var
246 (if binder_is_a_fv then
247 bindNewToReg binder node lf_info
252 closureCodeBody binder_info closure_info cc args body
255 -- BUILD VAP INFO TABLES IF NECESSARY
256 -- Don't build Vap info tables etc for
257 -- a function whose result is an unboxed type,
258 -- because we can never have thunks with such a type.
259 (if closureReturnsUnboxedType closure_info then
262 cgVapInfoTables False {- Not top level -} nopC binder_info binder args lf_info
267 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
269 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
270 ) `thenFC` \ heap_offset ->
273 returnFC (binder, heapIdInfo binder heap_offset lf_info)
276 @cgVapInfoTables@ generates both Vap info tables, if they are required
277 at all. It calls @cgVapInfoTable@ to generate each Vap info table,
278 along with its entry code.
281 -- Don't generate Vap info tables for thunks; only for functions
282 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
285 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
286 = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
287 (if stdVapRequired binder_info then
288 cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
293 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
294 (if noUpdVapRequired binder_info then
295 cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
301 fun_in_payload = not top_level
303 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
305 -- The vap_entry_rhs is a manufactured STG expression which
306 -- looks like the RHS of any binding which is going to use the vap-entry
307 -- point of the function. Each of these bindings will look like:
309 -- x = [a,b,c] \upd [] -> f a b c
311 -- If f is not top-level, then f is one of the free variables too,
312 -- hence "payload_ids" isn't the same as "arg_ids".
314 stg_args = map StgVarArg args
315 vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
318 arg_ids_w_info = [(name,mkLFArgument) | name <- args]
319 payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
320 | otherwise = arg_ids_w_info
322 payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
325 vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
326 -- It's not top level, even if we're currently compiling a top-level
327 -- function, because any VAP *use* of this function will be for a
329 -- let x = f p q -- x isn't top level!
332 get_kind (id, info) = idPrimRep id
334 payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
335 (closure_info, payload_bind_details) = layOutDynClosure
337 get_kind payload_ids_w_info
339 -- The dodgy thing is that we use the "fun" as the
340 -- Id to give to layOutDynClosure. This Id gets embedded in
341 -- the closure_info it returns. But of course, the function doesn't
342 -- have the right type to match the Vap closure. Never mind,
343 -- a hack in closureType spots the special case. Otherwise that
344 -- Id is just used for label construction, which is OK.
346 bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
349 -- BUILD ITS INFO TABLE AND CODE
352 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
353 -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
354 perhaps_bind_the_fun `thenC`
355 mapCs bind_fv payload_bind_details `thenC`
357 -- Generate the info table and code
358 closureCodeBody NoStgBinderInfo
361 [] -- No args; it's a thunk
365 %************************************************************************
367 \subsection[code-for-closures]{The code for closures}
369 %************************************************************************
372 closureCodeBody :: StgBinderInfo
373 -> ClosureInfo -- Lots of information about this closure
374 -> CostCentre -- Optional cost centre attached to closure
380 There are two main cases for the code for closures. If there are {\em
381 no arguments}, then the closure is a thunk, and not in normal form.
382 So it should set up an update frame (if it is shared). Also, it has
383 no argument satisfaction check, so fast and slow entry-point labels
387 closureCodeBody binder_info closure_info cc [] body
388 = -- thunks cannot have a primitive type!
392 = case (closureType closure_info) of
393 Nothing -> (False, panic "debug")
394 Just (tc,_,_) -> (True, tc)
396 if has_tycon && isPrimTyCon tycon then
397 pprPanic "closureCodeBody:thunk:prim type!" (ppr PprDebug tycon)
400 getAbsC body_code `thenFC` \ body_absC ->
401 moduleName `thenFC` \ mod_name ->
403 absC (CClosureInfoAndCode closure_info body_absC Nothing
404 stdUpd (cl_descr mod_name)
405 (dataConLiveness closure_info))
407 cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
409 body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
410 body_code = profCtrC SLIT("ENT_THK") [] `thenC`
411 thunkWrapper closure_info (
412 -- We only enter cc after setting up update so that cc
413 -- of enclosing scope will be recorded in update frame
414 -- CAF/DICT functions will be subsumed by this enclosing cc
415 enterCostCentreCode closure_info cc IsThunk `thenC`
418 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
421 If there is {\em at least one argument}, then this closure is in
422 normal form, so there is no need to set up an update frame. On the
423 other hand, we do have to check that there are enough args, and
424 perform an update if not!
426 The Macros for GrAnSim are produced at the beginning of the
427 argSatisfactionCheck (by calling fetchAndReschedule). There info if
428 Node points to closure is available. -- HWL
431 closureCodeBody binder_info closure_info cc all_args body
432 = getEntryConvention id lf_info
433 (map idPrimRep all_args) `thenFC` \ entry_conv ->
435 -- Arg mapping for standard (slow) entry point; all args on stack
436 (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
438 0 0 -- Initial virtual SpA, SpB
442 -- Arg mapping for the fast entry point; as many args as poss in
443 -- registers; the rest on the stack
444 -- arg_regs are the registers used for arg passing
445 -- stk_args are the args which are passed on the stack
447 arg_regs = case entry_conv of
448 DirectEntry lbl arity regs -> regs
449 ViaNode | is_concurrent -> []
450 other -> panic "closureCodeBody:arg_regs"
452 num_arg_regs = length arg_regs
454 (reg_args, stk_args) = splitAt num_arg_regs all_args
456 (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
458 0 0 -- Initial virtual SpA, SpB
462 -- HWL; Note: empty list of live regs in slow entry code
463 -- Old version (reschedule combined with heap check);
464 -- see argSatisfactionCheck for new version
465 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
466 -- where node = VanillaReg PtrRep 1
467 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
470 = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
472 -- Bind args, and record expected position of stk ptrs
473 mapCs bindNewToAStack all_bxd_w_offsets `thenC`
474 mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
475 setRealAndVirtualSps spA_all_args spB_all_args `thenC`
477 argSatisfactionCheck closure_info all_args `thenC`
479 -- OK, so there are enough args. Now we need to stuff as
480 -- many of them in registers as the fast-entry code
481 -- expects Note that the zipWith will give up when it hits
482 -- the end of arg_regs.
484 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
485 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
487 -- Now adjust real stack pointers
488 adjustRealSps spA_stk_args spB_stk_args `thenC`
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 SLIT(""), CString SLIT("")
509 -- Nuked for now; see comment at end of file
510 -- CString (_PK_ (show_wrapper_name wrapper_maybe)),
511 -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
515 -- Bind args to regs/stack as appropriate, and
516 -- record expected position of sps
517 bindArgsToRegs reg_args arg_regs `thenC`
518 mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
519 mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
520 setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
522 -- Enter the closures cc, if required
523 enterCostCentreCode closure_info cc IsFunction `thenC`
526 funWrapper closure_info arg_regs (cgExpr body)
528 -- Make a labelled code-block for the slow and fast entry code
529 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
530 `thenFC` \ slow_abs_c ->
531 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
532 moduleName `thenFC` \ mod_name ->
534 -- Now either construct the info table, or put the fast code in alone
535 -- (We never have slow code without an info table)
537 if info_table_needed then
538 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
539 stdUpd (cl_descr mod_name)
540 (dataConLiveness closure_info)
542 CCodeBlock fast_label fast_abs_c
545 is_concurrent = opt_ForConcurrent
546 stg_arity = length all_args
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
557 fast_label = mkFastEntryLabel id stg_arity
558 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
560 {- OLD... see note at end of file
561 wrapper_maybe = get_ultimate_wrapper Nothing id
563 get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
564 = case myWrapperMaybe x of
566 Just xx -> get_ultimate_wrapper (Just xx) xx
568 show_wrapper_name Nothing = ""
569 show_wrapper_name (Just xx) = showId PprDebug xx
571 show_wrapper_arg_kinds Nothing = ""
572 show_wrapper_arg_kinds (Just xx)
573 = 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
592 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
594 enterCostCentreCode closure_info cc is_thunk
595 = costCentresFlag `thenFC` \ profiling_on ->
596 if not profiling_on then
599 ASSERT(not (noCostCentreAttached cc))
601 if costsAreSubsumed cc then
602 --ASSERT(isToplevClosure closure_info)
603 --ASSERT(is_thunk == IsFunction)
604 (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, text (showCostCentre PprDebug False cc)])) $
605 costCentresC SLIT("ENTER_CC_FSUB") []
607 else if currentOrSubsumedCosts cc then
608 -- i.e. current; subsumed dealt with above
609 -- get CCC out of the closure, where we put it when we alloc'd
611 IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
612 IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
614 else if isCafCC cc && isToplevClosure closure_info then
615 ASSERT(is_thunk == IsThunk)
616 costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
618 else -- we've got a "real" cost centre right here in our hands...
620 IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
621 IsFunction -> if isCafCC cc || isDictCC cc
622 then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
623 else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
626 %************************************************************************
628 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
630 %************************************************************************
632 The argument-satisfaction check code is placed after binding
633 the arguments to their stack locations. Hence, the virtual stack
634 pointer is pointing after all the args, and virtual offset 1 means
635 the base of frame and hence most distant arg. Hence
636 virtual offset 0 is just beyond the most distant argument; the
637 relative offset of this word tells how many words of arguments
641 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
643 argSatisfactionCheck closure_info [] = nopC
645 argSatisfactionCheck closure_info args
646 = -- safest way to determine which stack last arg will be on:
647 -- look up CAddrMode that last arg is bound to;
649 -- check isFollowableRep.
651 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
654 emit_gran_macros = opt_GranMacros
658 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
659 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
662 then fetchAndReschedule [] node_points
663 else yield [] node_points
664 else absC AbsCNop) `thenC`
666 getCAddrMode (last args) `thenFC` \ last_amode ->
668 if (isFollowableRep (getAmodeRep last_amode)) then
669 getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
671 a_rel_int = spARelToInt spA off
672 a_rel_arg = mkIntCLit a_rel_int
674 ASSERT(a_rel_int /= 0)
676 absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
678 absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
680 getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
682 b_rel_int = spBRelToInt spB off
683 b_rel_arg = mkIntCLit b_rel_int
685 ASSERT(b_rel_int /= 0)
687 absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
689 absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
691 -- We must tell the arg-satis macro whether Node is pointing to
692 -- the closure or not. If it isn't so pointing, then we give to
693 -- the macro the (static) address of the closure.
695 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
698 %************************************************************************
700 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
702 %************************************************************************
705 thunkWrapper:: ClosureInfo -> Code -> Code
706 thunkWrapper closure_info thunk_code
707 = -- Stack and heap overflow checks
708 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
711 emit_gran_macros = opt_GranMacros
713 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
714 -- (we prefer fetchAndReschedule-style context switches to yield ones)
717 then fetchAndReschedule [] node_points
718 else yield [] node_points
719 else absC AbsCNop) `thenC`
721 stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
723 -- heapCheck must be after stackCheck: if stchk fails
724 -- new stack space is allocated from the heap which
725 -- would violate any previous heapCheck
727 heapCheck [] node_points ( -- 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 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
735 -- Finally, do the business
739 funWrapper :: ClosureInfo -- Closure whose code body this is
740 -> [MagicId] -- List of argument registers (if any)
741 -> Code -- Body of function being compiled
743 funWrapper closure_info arg_regs fun_body
744 = -- Stack overflow check
745 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
747 emit_gran_macros = opt_GranMacros
751 then yield arg_regs node_points
752 else absC AbsCNop) `thenC`
754 stackCheck closure_info arg_regs node_points (
755 -- stackCheck *encloses* the rest
757 heapCheck arg_regs node_points (
758 -- heapCheck *encloses* the rest
760 -- Finally, do the business
765 %************************************************************************
767 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
769 %************************************************************************
771 Assumption: virtual and real stack pointers are currently exactly aligned.
774 stackCheck :: ClosureInfo
775 -> [MagicId] -- Live registers
776 -> Bool -- Node required to point after check?
780 stackCheck closure_info regs node_reqd code
781 = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
783 getVirtSps `thenFC` \ (vSpA, vSpB) ->
785 let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
786 b_headroom_reqd = bHw - vSpB
789 absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
792 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
793 mkIntCLit a_headroom_reqd,
794 mkIntCLit b_headroom_reqd,
797 mkIntCLit (if returns_prim_type then 1 else 0),
798 mkIntCLit (if node_reqd then 1 else 0)]
800 -- The test is *inside* the absC, to avoid black holes!
805 all_regs = if node_reqd then node:regs else regs
806 liveness_mask = mkLiveRegsMask all_regs
808 returns_prim_type = closureReturnsUnboxedType closure_info
811 %************************************************************************
813 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
815 %************************************************************************
819 blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
820 blackHoleIt closure_info
821 = noBlackHolingFlag `thenFC` \ no_black_holing ->
823 if (blackHoleOnEntry no_black_holing closure_info)
825 absC (if closureSingleEntry(closure_info) then
826 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
828 CMacroStmt UPD_BH_UPDATABLE [CReg node])
829 -- Node always points to it; see stg-details
835 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
836 -- Nota Bene: this function does not change Node (even if it's a CAF),
837 -- so that the cost centre in the original closure can still be
838 -- extracted by a subsequent ENTER_CC_TCL
840 setupUpdate closure_info code
841 = if (closureUpdReqd closure_info) then
842 link_caf_if_needed `thenFC` \ update_closure ->
843 pushUpdateFrame update_closure vector code
845 profCtrC SLIT("UPDF_OMITTED") [] `thenC`
848 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
850 = if not (isStaticClosure closure_info) then
854 -- First we must allocate a black hole, and link the
855 -- CAF onto the CAF list
857 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
858 -- Hack Warning: Using a CLitLit to get CAddrMode !
860 use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
863 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
864 `thenFC` \ heap_offset ->
865 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
866 let amode = CAddr hp_rel
868 absC (CMacroStmt UPD_CAF [CReg node, amode])
873 = case (closureType closure_info) of
874 Nothing -> CReg StdUpdRetVecReg
875 Just (spec_tycon, _, spec_datacons) ->
876 case (ctrlReturnConvAlg spec_tycon) of
877 UnvectoredReturn 1 ->
879 spec_data_con = head spec_datacons
880 only_tag = dataConTag spec_data_con
882 direct = case (dataReturnConvAlg spec_data_con) of
883 ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
884 ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
886 vectored = mkStdUpdVecTblLabel spec_tycon
888 CUnVecLbl direct vectored
890 UnvectoredReturn _ -> CReg StdUpdRetVecReg
891 VectoredReturn _ -> CLbl (mkStdUpdVecTblLabel spec_tycon) DataPtrRep
894 %************************************************************************
896 \subsection[CgClosure-Description]{Profiling Closure Description.}
898 %************************************************************************
900 For "global" data constructors the description is simply occurrence
901 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
903 Otherwise it is determind by @closureDescription@ from the let
907 closureDescription :: FAST_STRING -- Module
908 -> Id -- Id of closure binding
913 -- Not called for StgRhsCon which have global info tables built in
914 -- CgConTbls.lhs with a description generated from the data constructor
916 closureDescription mod_name name args body
926 chooseDynCostCentres cc args fvs body
928 use_cc -- cost-centre we record in the object
929 = if currentOrSubsumedCosts cc
930 then CReg CurCostCentre
931 else mkCCostCentre cc
933 blame_cc -- cost-centre on whom we blame the allocation
934 = case (args, fvs, body) of
935 ([], [just1], StgApp (StgVarArg fun) [{-no args-}] _)
937 -> mkCCostCentre overheadCostCentre
940 -- if it's an utterly trivial RHS, then it must be
941 -- one introduced by boxHigherOrderArgs for profiling,
942 -- so we charge it to "OVERHEAD".
949 ========================================================================
950 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
952 It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
955 getWrapperArgTypeCategories
956 :: Type -- wrapper's type
957 -> StrictnessInfo bdee -- strictness info about its args
960 getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
961 getWrapperArgTypeCategories _ BottomGuaranteed
962 = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
963 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
965 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
966 = Just (mkWrapperArgTypeCategories ty arg_info)
968 mkWrapperArgTypeCategories
969 :: Type -- wrapper's type
970 -> [Demand] -- info about its arguments
971 -> String -- a string saying lots about the args
973 mkWrapperArgTypeCategories wrapper_ty wrap_info
974 = case (splitFunTyExpandingDicts wrapper_ty) of { (arg_tys,_) ->
975 map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
977 -- ToDo: this needs FIXING UP (it was a hack anyway...)
978 do_one (WwPrim, _) = 'P'
979 do_one (WwEnum, _) = 'E'
980 do_one (WwStrict, arg_ty_char) = arg_ty_char
981 do_one (WwUnpack _ _ _, arg_ty_char)
982 = if arg_ty_char `elem` "CIJFDTS"
983 then toLower arg_ty_char
984 else if arg_ty_char == '+' then 't'
985 else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
986 do_one (other_wrap_info, _) = '-'