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 module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
13 #include "HsVersions.h"
15 import {-# SOURCE #-} CgExpr ( cgExpr )
20 import BasicTypes ( TopLevelFlag(..) )
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 ( VirtualHeapOffset )
56 import Id ( idType, idPrimRep,
57 showId, getIdStrictness, dataConTag,
61 import ListSetOps ( minusList )
62 import Maybes ( maybeToBool )
63 import PrimRep ( isFollowableRep, PrimRep(..) )
64 import TyCon ( isPrimTyCon, tyConDataCons )
65 import Type ( showTypeCategory )
69 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
72 %********************************************************
74 \subsection[closures-no-free-vars]{Top-level closures}
76 %********************************************************
78 For closures bound at top level, allocate in static space.
79 They should have no free variables.
83 -> CostCentre -- Optional cost centre annotation
88 -> FCode (Id, CgIdInfo)
90 cgTopRhsClosure name cc binder_info args body lf_info
91 = -- LAY OUT THE OBJECT
93 closure_info = layOutStaticNoFVClosure name lf_info
96 -- GENERATE THE INFO TABLE (IF NECESSARY)
97 forkClosureBody (closureCodeBody binder_info closure_info
101 -- BUILD VAP INFO TABLES IF NECESSARY
103 bind_the_fun = addBindC name cg_id_info -- It's global!
105 cgVapInfoTables TopLevel bind_the_fun binder_info name args lf_info
108 -- BUILD THE OBJECT (IF NECESSARY)
109 (if staticClosureRequired name binder_info lf_info
112 cost_centre = mkCCostCentre cc
115 closure_label -- Labelled with the name on lhs of defn
123 returnFC (name, cg_id_info)
125 closure_label = mkClosureLabel name
126 cg_id_info = stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info
129 %********************************************************
131 \subsection[non-top-level-closures]{Non top-level closures}
133 %********************************************************
135 For closures with free vars, allocate in heap.
137 ===================== OLD PROBABLY OUT OF DATE COMMENTS =============
139 -- Closures which (a) have no fvs and (b) have some args (i.e.
140 -- combinator functions), are allocated statically, just as if they
141 -- were top-level closures. We can't get a space leak that way
142 -- (because they are HNFs) and it saves allocation.
144 -- Lexical Scoping: Problem
145 -- These top level function closures will be inherited, possibly
146 -- to a different cost centre scope set before entering.
148 -- Evaluation Scoping: ok as already in HNF
150 -- Should rely on floating mechanism to achieve this floating to top level.
151 -- As let floating will avoid floating which breaks cost centre attribution
152 -- everything will be OK.
154 -- Disabled: because it breaks lexical-scoped cost centre semantics.
155 -- cgRhsClosure binder cc bi [] upd_flag args@(_:_) body
156 -- = cgTopRhsClosure binder cc bi upd_flag args body
158 ===================== END OF OLD PROBABLY OUT OF DATE COMMENTS =============
162 -> CostCentre -- Optional cost centre annotation
168 -> FCode (Id, CgIdInfo)
170 cgRhsClosure binder cc binder_info fvs args body lf_info
171 | maybeToBool maybe_std_thunk -- AHA! A STANDARD-FORM THUNK
172 -- ToDo: check non-primitiveness (ASSERT)
174 -- LAY OUT THE OBJECT
175 getArgAmodes std_thunk_payload `thenFC` \ amodes ->
177 (closure_info, amodes_w_offsets)
178 = layOutDynClosure binder getAmodeRep amodes lf_info
180 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
183 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
185 `thenFC` \ heap_offset ->
188 returnFC (binder, heapIdInfo binder heap_offset lf_info)
191 maybe_std_thunk = getStandardFormThunkInfo lf_info
192 Just std_thunk_payload = maybe_std_thunk
195 Here's the general case.
197 cgRhsClosure binder cc binder_info fvs args body lf_info
199 -- LAY OUT THE OBJECT
201 -- If the binder is itself a free variable, then don't store
202 -- it in the closure. Instead, just bind it to Node on entry.
203 -- NB we can be sure that Node will point to it, because we
204 -- havn't told mkClosureLFInfo about this; so if the binder
205 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
206 -- stored in the closure itself, so it will make sure that
207 -- Node points to it...
209 is_elem = isIn "cgRhsClosure"
211 binder_is_a_fv = binder `is_elem` fvs
212 reduced_fvs = if binder_is_a_fv
213 then fvs `minusList` [binder]
216 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
218 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
220 closure_info :: ClosureInfo
221 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
223 (closure_info, bind_details)
224 = layOutDynClosure binder get_kind fvs_w_amodes_and_info lf_info
226 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
228 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
230 get_kind (id, amode_and_info) = idPrimRep id
232 -- BUILD ITS INFO TABLE AND CODE
235 mapCs bind_fv bind_details `thenC`
237 -- Bind the binder itself, if it is a free var
238 (if binder_is_a_fv then
239 bindNewToReg binder node lf_info
244 closureCodeBody binder_info closure_info cc args body
247 -- BUILD VAP INFO TABLES IF NECESSARY
248 cgVapInfoTables NotTopLevel nopC binder_info binder args lf_info
253 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
255 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
256 ) `thenFC` \ heap_offset ->
259 returnFC (binder, heapIdInfo binder heap_offset lf_info)
262 @cgVapInfoTables@ generates both Vap info tables, if they are required
263 at all. It calls @cgVapInfoTable@ to generate each Vap info table,
264 along with its entry code.
267 -- Don't generate Vap info tables for thunks; only for functions
268 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun [{- no args; a thunk! -}] lf_info
271 cgVapInfoTables top_level perhaps_bind_the_fun binder_info fun args lf_info
272 = -- BUILD THE STANDARD VAP-ENTRY STUFF IF NECESSARY
273 (if stdVapRequired binder_info then
274 cgVapInfoTable perhaps_bind_the_fun Updatable fun args fun_in_payload lf_info
279 -- BUILD THE NO-UPDATE VAP-ENTRY STUFF IF NECESSARY
280 (if noUpdVapRequired binder_info then
281 cgVapInfoTable perhaps_bind_the_fun SingleEntry fun args fun_in_payload lf_info
287 fun_in_payload = case top_level of
292 cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
293 | closureReturnsUnpointedType closure_info
294 -- Don't build Vap info tables etc for
295 -- a function whose result is an unboxed type,
296 -- because we can never have thunks with such a type.
302 -- Bind the fvs; if the fun is not in the payload, then bind_the_fun tells
303 -- how to bind it. If it is in payload it'll be bound by payload_bind_details.
304 perhaps_bind_the_fun `thenC`
305 mapCs bind_fv payload_bind_details `thenC`
307 -- Generate the info table and code
308 closureCodeBody NoStgBinderInfo
311 [] -- No args; it's a thunk
315 -- The vap_entry_rhs is a manufactured STG expression which
316 -- looks like the RHS of any binding which is going to use the vap-entry
317 -- point of the function. Each of these bindings will look like:
319 -- x = [a,b,c] \upd [] -> f a b c
321 -- If f is not top-level, then f is one of the free variables too,
322 -- hence "payload_ids" isn't the same as "arg_ids".
324 stg_args = map StgVarArg args
325 vap_entry_rhs = StgApp (StgVarArg fun) stg_args emptyIdSet
328 arg_ids_w_info = [(name,mkLFArgument) | name <- args]
329 payload_ids_w_info | fun_in_payload = (fun,fun_lf_info) : arg_ids_w_info
330 | otherwise = arg_ids_w_info
332 payload_ids | fun_in_payload = fun : args -- Sigh; needed for mkClosureLFInfo
335 vap_lf_info = mkVapLFInfo payload_ids upd_flag fun stg_args fun_in_payload
336 -- It's not top level, even if we're currently compiling a top-level
337 -- function, because any VAP *use* of this function will be for a
339 -- let x = f p q -- x isn't top level!
342 get_kind (id, info) = idPrimRep id
344 payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
345 (closure_info, payload_bind_details) = layOutDynClosure
347 get_kind payload_ids_w_info
349 -- The dodgy thing is that we use the "fun" as the
350 -- Id to give to layOutDynClosure. This Id gets embedded in
351 -- the closure_info it returns. But of course, the function doesn't
352 -- have the right type to match the Vap closure. Never mind,
353 -- a hack in closureType spots the special case. Otherwise that
354 -- Id is just used for label construction, which is OK.
356 bind_fv ((id,lf_info), offset) = bindNewToNode id offset lf_info
358 %************************************************************************
360 \subsection[code-for-closures]{The code for closures}
362 %************************************************************************
365 closureCodeBody :: StgBinderInfo
366 -> ClosureInfo -- Lots of information about this closure
367 -> CostCentre -- Optional cost centre attached to closure
373 There are two main cases for the code for closures. If there are {\em
374 no arguments}, then the closure is a thunk, and not in normal form.
375 So it should set up an update frame (if it is shared). Also, it has
376 no argument satisfaction check, so fast and slow entry-point labels
380 closureCodeBody binder_info closure_info cc [] body
381 = -- thunks cannot have a primitive type!
385 = case (closureType closure_info) of
386 Nothing -> (False, panic "debug")
387 Just (tc,_,_) -> (True, tc)
389 if has_tycon && isPrimTyCon tycon then
390 pprPanic "closureCodeBody:thunk:prim type!" (ppr tycon)
393 getAbsC body_code `thenFC` \ body_absC ->
394 moduleName `thenFC` \ mod_name ->
396 absC (CClosureInfoAndCode closure_info body_absC Nothing
397 stdUpd (cl_descr mod_name)
398 (dataConLiveness closure_info))
400 cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
402 body_addr = CLbl (entryLabelFromCI closure_info) CodePtrRep
403 body_code = profCtrC SLIT("ENT_THK") [] `thenC`
404 thunkWrapper closure_info (
405 -- We only enter cc after setting up update so that cc
406 -- of enclosing scope will be recorded in update frame
407 -- CAF/DICT functions will be subsumed by this enclosing cc
408 enterCostCentreCode closure_info cc IsThunk `thenC`
411 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
414 If there is {\em at least one argument}, then this closure is in
415 normal form, so there is no need to set up an update frame. On the
416 other hand, we do have to check that there are enough args, and
417 perform an update if not!
419 The Macros for GrAnSim are produced at the beginning of the
420 argSatisfactionCheck (by calling fetchAndReschedule). There info if
421 Node points to closure is available. -- HWL
424 closureCodeBody binder_info closure_info cc all_args body
425 = getEntryConvention id lf_info
426 (map idPrimRep all_args) `thenFC` \ entry_conv ->
428 -- Figure out what is needed and what isn't
429 slow_code_needed = slowFunEntryCodeRequired id binder_info entry_conv
430 info_table_needed = funInfoTableRequired id binder_info lf_info
432 -- Arg mapping for standard (slow) entry point; all args on stack
433 (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
435 0 0 -- Initial virtual SpA, SpB
439 -- Arg mapping for the fast entry point; as many args as poss in
440 -- registers; the rest on the stack
441 -- arg_regs are the registers used for arg passing
442 -- stk_args are the args which are passed on the stack
444 arg_regs = case entry_conv of
445 DirectEntry lbl arity regs -> regs
446 ViaNode | is_concurrent -> []
447 other -> panic "closureCodeBody:arg_regs"
449 num_arg_regs = length arg_regs
451 (reg_args, stk_args) = splitAt num_arg_regs all_args
453 (spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
455 0 0 -- Initial virtual SpA, SpB
459 -- HWL; Note: empty list of live regs in slow entry code
460 -- Old version (reschedule combined with heap check);
461 -- see argSatisfactionCheck for new version
462 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
463 -- where node = UnusedReg PtrRep 1
464 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
467 = profCtrC SLIT("ENT_FUN_STD") [] `thenC`
469 -- Bind args, and record expected position of stk ptrs
470 mapCs bindNewToAStack all_bxd_w_offsets `thenC`
471 mapCs bindNewToBStack all_ubxd_w_offsets `thenC`
472 setRealAndVirtualSps spA_all_args spB_all_args `thenC`
474 argSatisfactionCheck closure_info all_args `thenC`
476 -- OK, so there are enough args. Now we need to stuff as
477 -- many of them in registers as the fast-entry code
478 -- expects Note that the zipWith will give up when it hits
479 -- the end of arg_regs.
481 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
482 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes)) `thenC`
484 -- Now adjust real stack pointers
485 adjustRealSps spA_stk_args spB_stk_args `thenC`
487 absC (CFallThrough (CLbl fast_label CodePtrRep))
489 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
492 -- Old version (reschedule combined with heap check);
493 -- see argSatisfactionCheck for new version
494 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
497 = profCtrC SLIT("ENT_FUN_DIRECT") [
498 CLbl (mkRednCountsLabel id) PtrRep,
499 CString (_PK_ (showId id)),
500 mkIntCLit stg_arity, -- total # of args
501 mkIntCLit spA_stk_args, -- # passed on A stk
502 mkIntCLit spB_stk_args, -- B stk (rest in regs)
503 CString (_PK_ (map (showTypeCategory . idType) all_args)),
504 CString SLIT(""), CString SLIT("")
506 -- Nuked for now; see comment at end of file
507 -- CString (_PK_ (show_wrapper_name wrapper_maybe)),
508 -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
512 -- Bind args to regs/stack as appropriate, and
513 -- record expected position of sps
514 bindArgsToRegs reg_args arg_regs `thenC`
515 mapCs bindNewToAStack stk_bxd_w_offsets `thenC`
516 mapCs bindNewToBStack stk_ubxd_w_offsets `thenC`
517 setRealAndVirtualSps spA_stk_args spB_stk_args `thenC`
519 -- Enter the closures cc, if required
520 enterCostCentreCode closure_info cc IsFunction `thenC`
523 funWrapper closure_info arg_regs (cgExpr body)
525 -- Make a labelled code-block for the slow and fast entry code
526 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
527 `thenFC` \ slow_abs_c ->
528 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
529 moduleName `thenFC` \ mod_name ->
531 -- Now either construct the info table, or put the fast code in alone
532 -- (We never have slow code without an info table)
534 if info_table_needed then
535 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
536 stdUpd (cl_descr mod_name)
537 (dataConLiveness closure_info)
539 CCodeBlock fast_label fast_abs_c
542 is_concurrent = opt_ForConcurrent
543 stg_arity = length all_args
544 lf_info = closureLFInfo closure_info
546 cl_descr mod_name = closureDescription mod_name id all_args body
548 -- Manufacture labels
549 id = closureId closure_info
550 fast_label = mkFastEntryLabel id stg_arity
551 stdUpd = CLbl mkErrorStdEntryLabel CodePtrRep
553 {- OLD... see note at end of file
554 wrapper_maybe = get_ultimate_wrapper Nothing id
556 get_ultimate_wrapper deflt x -- walk all the way up a "wrapper chain"
557 = case myWrapperMaybe x of
559 Just xx -> get_ultimate_wrapper (Just xx) xx
561 show_wrapper_name Nothing = ""
562 show_wrapper_name (Just xx) = showId xx
564 show_wrapper_arg_kinds Nothing = ""
565 show_wrapper_arg_kinds (Just xx)
566 = case (getWrapperArgTypeCategories (idType xx) (getIdStrictness xx)) of
572 For lexically scoped profiling we have to load the cost centre from
573 the closure entered, if the costs are not supposed to be inherited.
574 This is done immediately on entering the fast entry point.
576 Load current cost centre from closure, if not inherited.
577 Node is guaranteed to point to it, if profiling and not inherited.
580 data IsThunk = IsThunk | IsFunction -- Bool-like, local
585 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
587 enterCostCentreCode closure_info cc is_thunk
588 = costCentresFlag `thenFC` \ profiling_on ->
589 if not profiling_on then
592 ASSERT(not (noCostCentreAttached cc))
594 if costsAreSubsumed cc then
595 --ASSERT(isToplevClosure closure_info)
596 --ASSERT(is_thunk == IsFunction)
597 (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (hsep [ppr (is_thunk == IsFunction){-, ppr closure_info-}, text (showCostCentre False cc)])) $
598 costCentresC SLIT("ENTER_CC_FSUB") []
600 else if currentOrSubsumedCosts cc then
601 -- i.e. current; subsumed dealt with above
602 -- get CCC out of the closure, where we put it when we alloc'd
604 IsThunk -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
605 IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
607 else if isCafCC cc && isToplevClosure closure_info then
608 ASSERT(is_thunk == IsThunk)
609 costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
611 else -- we've got a "real" cost centre right here in our hands...
613 IsThunk -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
614 IsFunction -> if isCafCC cc || isDictCC cc
615 then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
616 else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
619 %************************************************************************
621 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
623 %************************************************************************
625 The argument-satisfaction check code is placed after binding
626 the arguments to their stack locations. Hence, the virtual stack
627 pointer is pointing after all the args, and virtual offset 1 means
628 the base of frame and hence most distant arg. Hence
629 virtual offset 0 is just beyond the most distant argument; the
630 relative offset of this word tells how many words of arguments
634 argSatisfactionCheck :: ClosureInfo -> [Id] -> Code
636 argSatisfactionCheck closure_info [] = nopC
638 argSatisfactionCheck closure_info args
639 = -- safest way to determine which stack last arg will be on:
640 -- look up CAddrMode that last arg is bound to;
642 -- check isFollowableRep.
644 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
647 emit_gran_macros = opt_GranMacros
651 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
652 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
655 then fetchAndReschedule [] node_points
656 else yield [] node_points
657 else absC AbsCNop) `thenC`
659 getCAddrMode (last args) `thenFC` \ last_amode ->
661 if (isFollowableRep (getAmodeRep last_amode)) then
662 getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
664 a_rel_int = spARelToInt spA off
665 a_rel_arg = mkIntCLit a_rel_int
667 ASSERT(a_rel_int /= 0)
669 absC (CMacroStmt ARGS_CHK_A [a_rel_arg])
671 absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [a_rel_arg, set_Node_to_this])
673 getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
675 b_rel_int = spBRelToInt spB off
676 b_rel_arg = mkIntCLit b_rel_int
678 ASSERT(b_rel_int /= 0)
680 absC (CMacroStmt ARGS_CHK_B [b_rel_arg])
682 absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [b_rel_arg, set_Node_to_this])
684 -- We must tell the arg-satis macro whether Node is pointing to
685 -- the closure or not. If it isn't so pointing, then we give to
686 -- the macro the (static) address of the closure.
688 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
691 %************************************************************************
693 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
695 %************************************************************************
698 thunkWrapper:: ClosureInfo -> Code -> Code
699 thunkWrapper closure_info thunk_code
700 = -- Stack and heap overflow checks
701 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
704 emit_gran_macros = opt_GranMacros
706 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
707 -- (we prefer fetchAndReschedule-style context switches to yield ones)
710 then fetchAndReschedule [] node_points
711 else yield [] node_points
712 else absC AbsCNop) `thenC`
714 stackCheck closure_info [] node_points ( -- stackCheck *encloses* the rest
716 -- heapCheck must be after stackCheck: if stchk fails
717 -- new stack space is allocated from the heap which
718 -- would violate any previous heapCheck
720 heapCheck [] node_points ( -- heapCheck *encloses* the rest
721 -- The "[]" says there are no live argument registers
723 -- Overwrite with black hole if necessary
724 blackHoleIt closure_info `thenC`
726 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
728 -- Finally, do the business
732 funWrapper :: ClosureInfo -- Closure whose code body this is
733 -> [MagicId] -- List of argument registers (if any)
734 -> Code -- Body of function being compiled
736 funWrapper closure_info arg_regs fun_body
737 = -- Stack overflow check
738 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
740 emit_gran_macros = opt_GranMacros
744 then yield arg_regs node_points
745 else absC AbsCNop) `thenC`
747 stackCheck closure_info arg_regs node_points (
748 -- stackCheck *encloses* the rest
750 heapCheck arg_regs node_points (
751 -- heapCheck *encloses* the rest
753 -- Finally, do the business
758 %************************************************************************
760 \subsubsubsection[overflow-checks]{Stack and heap overflow wrappers}
762 %************************************************************************
764 Assumption: virtual and real stack pointers are currently exactly aligned.
767 stackCheck :: ClosureInfo
768 -> [MagicId] -- Live registers
769 -> Bool -- Node required to point after check?
773 stackCheck closure_info regs node_reqd code
774 = getFinalStackHW (\ aHw -> \ bHw -> -- Both virtual stack offsets
776 getVirtSps `thenFC` \ (vSpA, vSpB) ->
778 let a_headroom_reqd = aHw - vSpA -- Virtual offsets are positive integers
779 b_headroom_reqd = bHw - vSpB
782 absC (if (a_headroom_reqd == 0 && b_headroom_reqd == 0) then
785 CMacroStmt STK_CHK [mkIntCLit liveness_mask,
786 mkIntCLit a_headroom_reqd,
787 mkIntCLit b_headroom_reqd,
790 mkIntCLit (if returns_prim_type then 1 else 0),
791 mkIntCLit (if node_reqd then 1 else 0)]
793 -- The test is *inside* the absC, to avoid black holes!
798 all_regs = if node_reqd then node:regs else regs
799 liveness_mask = mkLiveRegsMask all_regs
801 returns_prim_type = closureReturnsUnpointedType closure_info
804 %************************************************************************
806 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
808 %************************************************************************
812 blackHoleIt :: ClosureInfo -> Code -- Only called for thunks
813 blackHoleIt closure_info
814 = noBlackHolingFlag `thenFC` \ no_black_holing ->
816 if (blackHoleOnEntry no_black_holing closure_info)
818 absC (if closureSingleEntry(closure_info) then
819 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
821 CMacroStmt UPD_BH_UPDATABLE [CReg node])
822 -- Node always points to it; see stg-details
828 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
829 -- Nota Bene: this function does not change Node (even if it's a CAF),
830 -- so that the cost centre in the original closure can still be
831 -- extracted by a subsequent ENTER_CC_TCL
833 setupUpdate closure_info code
834 = if (closureUpdReqd closure_info) then
835 link_caf_if_needed `thenFC` \ update_closure ->
836 pushUpdateFrame update_closure vector code
838 profCtrC SLIT("UPDF_OMITTED") [] `thenC`
841 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
843 = if not (isStaticClosure closure_info) then
847 -- First we must allocate a black hole, and link the
848 -- CAF onto the CAF list
850 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
851 -- Hack Warning: Using a CLitLit to get CAddrMode !
853 use_cc = CLitLit SLIT("CC_HDR(R1.p)") PtrRep
856 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
857 `thenFC` \ heap_offset ->
858 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
859 let amode = CAddr hp_rel
861 absC (CMacroStmt UPD_CAF [CReg node, amode])
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
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
933 -- if it's an utterly trivial RHS, then it must be
934 -- one introduced by boxHigherOrderArgs for profiling,
935 -- so we charge it to "OVERHEAD".
942 ========================================================================
943 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
945 It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
948 getWrapperArgTypeCategories
949 :: Type -- wrapper's type
950 -> StrictnessInfo bdee -- strictness info about its args
953 getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
954 getWrapperArgTypeCategories _ BottomGuaranteed
955 = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
956 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
958 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
959 = Just (mkWrapperArgTypeCategories ty arg_info)
961 mkWrapperArgTypeCategories
962 :: Type -- wrapper's type
963 -> [Demand] -- info about its arguments
964 -> String -- a string saying lots about the args
966 mkWrapperArgTypeCategories wrapper_ty wrap_info
967 = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
968 map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
970 -- ToDo: this needs FIXING UP (it was a hack anyway...)
971 do_one (WwPrim, _) = 'P'
972 do_one (WwEnum, _) = 'E'
973 do_one (WwStrict, arg_ty_char) = arg_ty_char
974 do_one (WwUnpack _ _ _, arg_ty_char)
975 = if arg_ty_char `elem` "CIJFDTS"
976 then toLower arg_ty_char
977 else if arg_ty_char == '+' then 't'
978 else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
979 do_one (other_wrap_info, _) = '-'