2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.23 1999/01/21 10:31:55 simonm Exp $
6 \section[CgClosure]{Code generation for closures}
8 This module provides the support code for @StgToAbstractC@ to deal
9 with {\em closures} on the RHSs of let(rec)s. See also
10 @CgCon@, which deals with constructors.
13 module CgClosure ( cgTopRhsClosure,
16 closureCodeBody ) where
18 #include "HsVersions.h"
20 import {-# SOURCE #-} CgExpr ( cgExpr )
25 import BasicTypes ( TopLevelFlag(..) )
27 import AbsCUtils ( mkAbstractCs, getAmodeRep )
28 import CgBindery ( getCAddrMode, getArgAmodes,
29 getCAddrModeAndInfo, bindNewToNode,
31 bindNewToReg, bindArgsToRegs,
32 stableAmodeIdInfo, heapIdInfo, CgIdInfo
34 import CgUpdate ( pushUpdateFrame )
35 import CgHeapery ( allocDynClosure,
36 fetchAndReschedule, yield, -- HWL
37 fastEntryChecks, thunkChecks
39 import CgStackery ( adjustRealSp, mkTaggedVirtStkOffsets, freeStackSlots )
40 import CgUsages ( setRealAndVirtualSp, getVirtSp,
41 getSpRelOffset, getHpRelOffset
43 import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
44 mkRednCountsLabel, mkStdEntryLabel
46 import ClosureInfo -- lots and lots of stuff
47 import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn )
49 import Id ( Id, idName, idType, idPrimRep )
50 import Name ( Name, Module, pprModule )
51 import ListSetOps ( minusList )
52 import PrimRep ( PrimRep(..) )
53 import PprType ( showTypeCategory )
55 import CmdLineOpts ( opt_SccProfilingOn )
58 getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
61 %********************************************************
63 \subsection[closures-no-free-vars]{Top-level closures}
65 %********************************************************
67 For closures bound at top level, allocate in static space.
68 They should have no free variables.
72 -> CostCentreStack -- Optional cost centre annotation
78 -> FCode (Id, CgIdInfo)
80 cgTopRhsClosure id ccs binder_info srt args body lf_info
81 = -- LAY OUT THE OBJECT
83 closure_info = layOutStaticNoFVClosure name lf_info
86 -- BUILD THE OBJECT (IF NECESSARY)
87 ({- if staticClosureRequired name binder_info lf_info
89 (if opt_SccProfilingOn
92 closure_label -- Labelled with the name on lhs of defn
94 (mkCCostCentreStack ccs)
98 closure_label -- Labelled with the name on lhs of defn
108 -- GENERATE THE INFO TABLE (IF NECESSARY)
109 forkClosureBody (closureCodeBody binder_info srt closure_info
114 returnFC (id, cg_id_info)
117 closure_label = mkClosureLabel name
118 cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
121 %********************************************************
123 \subsection[non-top-level-closures]{Non top-level closures}
125 %********************************************************
127 For closures with free vars, allocate in heap.
132 -> CostCentreStack -- Optional cost centre annotation
139 -> [StgArg] -- payload
140 -> FCode (Id, CgIdInfo)
142 cgStdRhsClosure binder cc binder_info srt fvs args body lf_info payload
143 -- AHA! A STANDARD-FORM THUNK
145 -- LAY OUT THE OBJECT
146 getArgAmodes payload `thenFC` \ amodes ->
148 (closure_info, amodes_w_offsets)
149 = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
151 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
154 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
156 `thenFC` \ heap_offset ->
159 returnFC (binder, heapIdInfo binder heap_offset lf_info)
162 is_std_thunk = isStandardFormThunk lf_info
165 Here's the general case.
169 -> CostCentreStack -- Optional cost centre annotation
176 -> FCode (Id, CgIdInfo)
178 cgRhsClosure binder cc binder_info srt fvs args body lf_info
180 -- LAY OUT THE OBJECT
182 -- If the binder is itself a free variable, then don't store
183 -- it in the closure. Instead, just bind it to Node on entry.
184 -- NB we can be sure that Node will point to it, because we
185 -- havn't told mkClosureLFInfo about this; so if the binder
186 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
187 -- stored in the closure itself, so it will make sure that
188 -- Node points to it...
190 is_elem = isIn "cgRhsClosure"
192 binder_is_a_fv = binder `is_elem` fvs
193 reduced_fvs = if binder_is_a_fv
194 then fvs `minusList` [binder]
197 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
199 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
201 closure_info :: ClosureInfo
202 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
204 (closure_info, bind_details)
205 = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
207 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
209 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
211 get_kind (id, amode_and_info) = idPrimRep id
213 -- BUILD ITS INFO TABLE AND CODE
216 mapCs bind_fv bind_details `thenC`
218 -- Bind the binder itself, if it is a free var
219 (if binder_is_a_fv then
220 bindNewToReg binder node lf_info
225 closureCodeBody binder_info srt closure_info cc args body
230 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
232 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
233 ) `thenFC` \ heap_offset ->
236 returnFC (binder, heapIdInfo binder heap_offset lf_info)
239 %************************************************************************
241 \subsection[code-for-closures]{The code for closures}
243 %************************************************************************
246 closureCodeBody :: StgBinderInfo
248 -> ClosureInfo -- Lots of information about this closure
249 -> CostCentreStack -- Optional cost centre attached to closure
255 There are two main cases for the code for closures. If there are {\em
256 no arguments}, then the closure is a thunk, and not in normal form.
257 So it should set up an update frame (if it is shared). Also, it has
258 no argument satisfaction check, so fast and slow entry-point labels
262 closureCodeBody binder_info srt closure_info cc [] body
263 = -- thunks cannot have a primitive type!
264 getAbsC body_code `thenFC` \ body_absC ->
265 moduleName `thenFC` \ mod_name ->
266 getSRTLabel `thenFC` \ srt_label ->
268 absC (CClosureInfoAndCode closure_info body_absC Nothing
269 (srt_label, srt) (cl_descr mod_name))
271 cl_descr mod_name = closureDescription mod_name (closureName closure_info)
273 body_label = entryLabelFromCI closure_info
274 body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
275 thunkWrapper closure_info body_label (
276 -- We only enter cc after setting up update so that cc
277 -- of enclosing scope will be recorded in update frame
278 -- CAF/DICT functions will be subsumed by this enclosing cc
279 enterCostCentreCode closure_info cc IsThunk `thenC`
283 If there is {\em at least one argument}, then this closure is in
284 normal form, so there is no need to set up an update frame. On the
285 other hand, we do have to check that there are enough args, and
286 perform an update if not!
288 The Macros for GrAnSim are produced at the beginning of the
289 argSatisfactionCheck (by calling fetchAndReschedule). There info if
290 Node points to closure is available. -- HWL
293 closureCodeBody binder_info srt closure_info cc all_args body
294 = getEntryConvention name lf_info
295 (map idPrimRep all_args) `thenFC` \ entry_conv ->
297 -- get the current virtual Sp (it might not be zero, eg. if we're
298 -- compiling a let-no-escape).
299 getVirtSp `thenFC` \vSp ->
301 -- Figure out what is needed and what isn't
303 -- SDM: need everything for now in case the heap/stack check refers
305 slow_code_needed = True
306 --slowFunEntryCodeRequired name binder_info entry_conv
307 info_table_needed = True
308 --funInfoTableRequired name binder_info lf_info
310 -- Arg mapping for standard (slow) entry point; all args on stack,
312 (sp_all_args, arg_offsets, arg_tags)
313 = mkTaggedVirtStkOffsets vSp idPrimRep all_args
315 -- Arg mapping for the fast entry point; as many args as poss in
316 -- registers; the rest on the stack
317 -- arg_regs are the registers used for arg passing
318 -- stk_args are the args which are passed on the stack
320 -- Args passed on the stack are tagged, but the tags may not
321 -- actually be present (just gaps) if the function is called
322 -- by jumping directly to the fast entry point.
324 arg_regs = case entry_conv of
325 DirectEntry lbl arity regs -> regs
326 other -> panic "closureCodeBody:arg_regs"
328 num_arg_regs = length arg_regs
330 (reg_args, stk_args) = splitAt num_arg_regs all_args
332 (sp_stk_args, stk_offsets, stk_tags)
333 = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
335 -- HWL; Note: empty list of live regs in slow entry code
336 -- Old version (reschedule combined with heap check);
337 -- see argSatisfactionCheck for new version
338 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
339 -- where node = UnusedReg PtrRep 1
340 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
343 = profCtrC SLIT("TICK_ENT_FUN_STD") [] `thenC`
345 -- Bind args, and record expected position of stk ptrs
346 mapCs bindNewToStack arg_offsets `thenC`
347 setRealAndVirtualSp sp_all_args `thenC`
349 argSatisfactionCheck closure_info `thenC`
351 -- OK, so there are enough args. Now we need to stuff as
352 -- many of them in registers as the fast-entry code
353 -- expects. Note that the zipWith will give up when it hits
354 -- the end of arg_regs.
356 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
357 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
360 -- Now adjust real stack pointers
361 adjustRealSp sp_stk_args `thenC`
363 absC (CFallThrough (CLbl fast_label CodePtrRep))
365 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
368 -- Old version (reschedule combined with heap check);
369 -- see argSatisfactionCheck for new version
370 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
373 = profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
374 mkIntCLit stg_arity -- total # of args
376 {- CLbl (mkRednCountsLabel name) PtrRep,
377 CString (_PK_ (showSDoc (ppr name))),
378 mkIntCLit stg_arity, -- total # of args
379 mkIntCLit sp_stk_args, -- # passed on stk
380 CString (_PK_ (map (showTypeCategory . idType) all_args)),
381 CString SLIT(""), CString SLIT("")
384 -- Nuked for now; see comment at end of file
385 -- CString (_PK_ (show_wrapper_name wrapper_maybe)),
386 -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
390 -- Bind args to regs/stack as appropriate, and
391 -- record expected position of sps.
392 bindArgsToRegs reg_args arg_regs `thenC`
393 mapCs bindNewToStack stk_offsets `thenC`
394 setRealAndVirtualSp sp_stk_args `thenC`
396 -- free up the stack slots containing tags
397 freeStackSlots (map fst stk_tags) `thenC`
399 -- Enter the closures cc, if required
400 enterCostCentreCode closure_info cc IsFunction `thenC`
403 funWrapper closure_info arg_regs stk_tags slow_label (cgExpr body)
405 -- Make a labelled code-block for the slow and fast entry code
406 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
407 `thenFC` \ slow_abs_c ->
408 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
409 moduleName `thenFC` \ mod_name ->
410 getSRTLabel `thenFC` \ srt_label ->
412 -- Now either construct the info table, or put the fast code in alone
413 -- (We never have slow code without an info table)
414 -- XXX probably need the info table and slow entry code in case of
415 -- a heap check failure.
417 if info_table_needed then
418 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
419 (srt_label, srt) (cl_descr mod_name)
421 CCodeBlock fast_label fast_abs_c
424 stg_arity = length all_args
425 lf_info = closureLFInfo closure_info
427 cl_descr mod_name = closureDescription mod_name name
429 -- Manufacture labels
430 name = closureName closure_info
431 fast_label = mkFastEntryLabel name stg_arity
432 slow_label = mkStdEntryLabel name
435 For lexically scoped profiling we have to load the cost centre from
436 the closure entered, if the costs are not supposed to be inherited.
437 This is done immediately on entering the fast entry point.
439 Load current cost centre from closure, if not inherited.
440 Node is guaranteed to point to it, if profiling and not inherited.
443 data IsThunk = IsThunk | IsFunction -- Bool-like, local
448 enterCostCentreCode :: ClosureInfo -> CostCentreStack -> IsThunk -> Code
450 enterCostCentreCode closure_info ccs is_thunk
451 = if not opt_SccProfilingOn then
454 ASSERT(not (noCCSAttached ccs))
456 if isSubsumedCCS ccs then
457 --ASSERT(isToplevClosure closure_info)
458 --ASSERT(is_thunk == IsFunction)
459 (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x
460 else pprTrace "enterCostCenterCode:" (hsep [ppr (is_thunk == IsFunction),
462 costCentresC SLIT("ENTER_CCS_FSUB") []
464 else if isCurrentCCS ccs then
465 -- get CCC out of the closure, where we put it when we alloc'd
467 IsThunk -> costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
468 IsFunction -> costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
470 else if isCafCCS ccs && isToplevClosure closure_info then
471 ASSERT(is_thunk == IsThunk)
472 costCentresC SLIT("ENTER_CCS_CAF") c_ccs
474 else -- we've got a "real" cost centre right here in our hands...
476 IsThunk -> costCentresC SLIT("ENTER_CCS_T") c_ccs
477 IsFunction -> if isCafCCS ccs-- || isDictCC ccs
478 then costCentresC SLIT("ENTER_CCS_FCAF") c_ccs
479 else costCentresC SLIT("ENTER_CCS_FLOAD") c_ccs
481 c_ccs = [mkCCostCentreStack ccs]
484 %************************************************************************
486 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
488 %************************************************************************
490 The argument-satisfaction check code is placed after binding
491 the arguments to their stack locations. Hence, the virtual stack
492 pointer is pointing after all the args, and virtual offset 1 means
493 the base of frame and hence most distant arg. Hence
494 virtual offset 0 is just beyond the most distant argument; the
495 relative offset of this word tells how many words of arguments
499 argSatisfactionCheck :: ClosureInfo -> Code
501 argSatisfactionCheck closure_info
503 = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
506 emit_gran_macros = opt_GranMacros
510 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
511 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
514 then fetchAndReschedule [] node_points
515 else yield [] node_points
516 else absC AbsCNop) `thenC`
518 getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
521 rel_arg = mkIntCLit off
525 absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
527 absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
529 -- We must tell the arg-satis macro whether Node is pointing to
530 -- the closure or not. If it isn't so pointing, then we give to
531 -- the macro the (static) address of the closure.
533 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
536 %************************************************************************
538 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
540 %************************************************************************
543 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
544 thunkWrapper closure_info label thunk_code
545 = -- Stack and heap overflow checks
546 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
549 emit_gran_macros = opt_GranMacros
551 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
552 -- (we prefer fetchAndReschedule-style context switches to yield ones)
555 then fetchAndReschedule [] node_points
556 else yield [] node_points
557 else absC AbsCNop) `thenC`
559 -- stack and/or heap checks
560 thunkChecks label node_points (
562 -- Overwrite with black hole if necessary
563 blackHoleIt closure_info node_points `thenC`
565 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
567 -- Finally, do the business
571 funWrapper :: ClosureInfo -- Closure whose code body this is
572 -> [MagicId] -- List of argument registers (if any)
573 -> [(VirtualSpOffset,Int)] -- tagged stack slots
574 -> CLabel -- slow entry point for heap check ret.
575 -> Code -- Body of function being compiled
577 funWrapper closure_info arg_regs stk_tags slow_label fun_body
578 = -- Stack overflow check
579 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
581 emit_gran_macros = opt_GranMacros
585 then yield arg_regs node_points
586 else absC AbsCNop) `thenC`
588 -- heap and/or stack checks
589 fastEntryChecks arg_regs stk_tags slow_label node_points (
591 -- Finally, do the business
597 %************************************************************************
599 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
601 %************************************************************************
605 blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for thunks
606 blackHoleIt closure_info node_points
607 = if blackHoleOnEntry closure_info && node_points
609 absC (if closureSingleEntry(closure_info) then
610 CMacroStmt UPD_BH_SINGLE_ENTRY [CReg node]
612 CMacroStmt UPD_BH_UPDATABLE [CReg node])
618 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
619 -- Nota Bene: this function does not change Node (even if it's a CAF),
620 -- so that the cost centre in the original closure can still be
621 -- extracted by a subsequent ENTER_CC_TCL
623 setupUpdate closure_info code
624 = if (closureUpdReqd closure_info) then
625 link_caf_if_needed `thenFC` \ update_closure ->
626 pushUpdateFrame update_closure code
628 profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
631 link_caf_if_needed :: FCode CAddrMode -- Returns amode for closure to be updated
633 = if not (isStaticClosure closure_info) then
637 -- First we must allocate a black hole, and link the
638 -- CAF onto the CAF list
640 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
641 -- Hack Warning: Using a CLitLit to get CAddrMode !
643 use_cc = CLitLit SLIT("CCS_HDR(R1.p)") PtrRep
646 allocDynClosure (blackHoleClosureInfo closure_info) use_cc blame_cc []
647 `thenFC` \ heap_offset ->
648 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
649 let amode = CAddr hp_rel
651 absC (CMacroStmt UPD_CAF [CReg node, amode])
656 %************************************************************************
658 \subsection[CgClosure-Description]{Profiling Closure Description.}
660 %************************************************************************
662 For "global" data constructors the description is simply occurrence
663 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
665 Otherwise it is determind by @closureDescription@ from the let
669 closureDescription :: Module -- Module
670 -> Name -- Id of closure binding
673 -- Not called for StgRhsCon which have global info tables built in
674 -- CgConTbls.lhs with a description generated from the data constructor
676 closureDescription mod_name name
686 chooseDynCostCentres ccs args fvs body
688 use_cc -- cost-centre we record in the object
689 = if currentOrSubsumedCCS ccs
690 then CReg CurCostCentre
691 else mkCCostCentreStack ccs
693 blame_cc -- cost-centre on whom we blame the allocation
694 = case (args, fvs, body) of
695 ([], [just1], StgApp fun [{-no args-}])
697 -> mkCCostCentreStack overheadCCS
700 -- if it's an utterly trivial RHS, then it must be
701 -- one introduced by boxHigherOrderArgs for profiling,
702 -- so we charge it to "OVERHEAD".
704 -- This looks like a HACK to me --SDM
711 ========================================================================
712 OLD CODE THAT EMITTED INFORMATON FOR QUANTITATIVE ANALYSIS
714 It's pretty wierd, so I've nuked it for now. SLPJ Nov 96
717 getWrapperArgTypeCategories
718 :: Type -- wrapper's type
719 -> StrictnessInfo bdee -- strictness info about its args
722 getWrapperArgTypeCategories _ NoStrictnessInfo = Nothing
723 getWrapperArgTypeCategories _ BottomGuaranteed
724 = trace "getWrapperArgTypeCategories:BottomGuaranteed!" Nothing -- wrong
725 getWrapperArgTypeCategories _ (StrictnessInfo [] _) = Nothing
727 getWrapperArgTypeCategories ty (StrictnessInfo arg_info _)
728 = Just (mkWrapperArgTypeCategories ty arg_info)
730 mkWrapperArgTypeCategories
731 :: Type -- wrapper's type
732 -> [Demand] -- info about its arguments
733 -> String -- a string saying lots about the args
735 mkWrapperArgTypeCategories wrapper_ty wrap_info
736 = case (splitFunTy_maybe wrapper_ty) of { Just (arg_tys,_) ->
737 map do_one (wrap_info `zip` (map showTypeCategory arg_tys)) }
739 -- ToDo: this needs FIXING UP (it was a hack anyway...)
740 do_one (WwPrim, _) = 'P'
741 do_one (WwEnum, _) = 'E'
742 do_one (WwStrict, arg_ty_char) = arg_ty_char
743 do_one (WwUnpack _ _ _, arg_ty_char)
744 = if arg_ty_char `elem` "CIJFDTS"
745 then toLower arg_ty_char
746 else if arg_ty_char == '+' then 't'
747 else trace ("mkWrapp..:funny char:"++[arg_ty_char]) '-'
748 do_one (other_wrap_info, _) = '-'