2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.60 2003/05/14 09:13:53 simonmar 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 )
24 import CgUpdate ( pushUpdateFrame )
28 import ClosureInfo -- lots and lots of stuff
30 import AbsCUtils ( getAmodeRep, mkAbstractCs )
35 import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
37 import Id ( Id, idName, idType, idPrimRep )
38 import Name ( Name, isInternalName )
39 import Module ( Module, pprModule )
40 import ListSetOps ( minusList )
41 import PrimRep ( PrimRep(..), getPrimRepSize )
42 import PprType ( showTypeCategory )
43 import Util ( isIn, splitAtList )
44 import CmdLineOpts ( opt_SccProfilingOn )
48 import Name ( nameOccName )
49 import OccName ( occNameFS )
52 %********************************************************
54 \subsection[closures-no-free-vars]{Top-level closures}
56 %********************************************************
58 For closures bound at top level, allocate in static space.
59 They should have no free variables.
63 -> CostCentreStack -- Optional cost centre annotation
69 -> FCode (Id, CgIdInfo)
71 cgTopRhsClosure id ccs binder_info srt args body lf_info
77 getSRTInfo name srt `thenFC` \ srt_info ->
78 moduleName `thenFC` \ mod_name ->
81 descr = closureDescription mod_name name
82 closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
83 closure_label = mkClosureLabel name
84 cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
87 -- BUILD THE OBJECT (IF NECESSARY)
89 ({- if staticClosureRequired name binder_info lf_info
91 absC (mkStaticClosure closure_label closure_info ccs [] True)
97 -- GENERATE THE INFO TABLE (IF NECESSARY)
98 forkClosureBody (closureCodeBody binder_info closure_info
103 returnFC (id, cg_id_info)
107 %********************************************************
109 \subsection[non-top-level-closures]{Non top-level closures}
111 %********************************************************
113 For closures with free vars, allocate in heap.
118 -> CostCentreStack -- Optional cost centre annotation
124 -> [StgArg] -- payload
125 -> FCode (Id, CgIdInfo)
127 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
128 -- AHA! A STANDARD-FORM THUNK
130 -- LAY OUT THE OBJECT
131 getArgAmodes payload `thenFC` \ amodes ->
132 moduleName `thenFC` \ mod_name ->
134 descr = closureDescription mod_name (idName binder)
136 (closure_info, amodes_w_offsets)
137 = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
138 -- No SRT for a standard-form closure
140 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
144 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
146 `thenFC` \ heap_offset ->
149 returnFC (binder, heapIdInfo binder heap_offset lf_info)
152 Here's the general case.
156 -> CostCentreStack -- Optional cost centre annotation
163 -> FCode (Id, CgIdInfo)
165 cgRhsClosure binder cc binder_info srt fvs args body lf_info
167 -- LAY OUT THE OBJECT
169 -- If the binder is itself a free variable, then don't store
170 -- it in the closure. Instead, just bind it to Node on entry.
171 -- NB we can be sure that Node will point to it, because we
172 -- havn't told mkClosureLFInfo about this; so if the binder
173 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
174 -- stored in the closure itself, so it will make sure that
175 -- Node points to it...
177 is_elem = isIn "cgRhsClosure"
179 binder_is_a_fv = binder `is_elem` fvs
180 reduced_fvs = if binder_is_a_fv
181 then fvs `minusList` [binder]
187 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
188 getSRTInfo name srt `thenFC` \ srt_info ->
189 moduleName `thenFC` \ mod_name ->
191 descr = closureDescription mod_name (idName binder)
193 closure_info :: ClosureInfo
194 bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
196 (closure_info, bind_details)
197 = layOutDynClosure binder get_kind
198 fvs_w_amodes_and_info lf_info srt_info descr
200 bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
202 amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
204 get_kind (id, _, _) = idPrimRep id
207 -- BUILD ITS INFO TABLE AND CODE
210 mapCs bind_fv bind_details `thenC`
212 -- Bind the binder itself, if it is a free var
213 (if binder_is_a_fv then
214 bindNewToReg binder node lf_info
219 closureCodeBody binder_info closure_info cc args body
224 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
226 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
227 ) `thenFC` \ heap_offset ->
230 returnFC (binder, heapIdInfo binder heap_offset lf_info)
233 %************************************************************************
235 \subsection[code-for-closures]{The code for closures}
237 %************************************************************************
240 closureCodeBody :: StgBinderInfo
241 -> ClosureInfo -- Lots of information about this closure
242 -> CostCentreStack -- Optional cost centre attached to closure
248 There are two main cases for the code for closures. If there are {\em
249 no arguments}, then the closure is a thunk, and not in normal form.
250 So it should set up an update frame (if it is shared).
253 closureCodeBody binder_info closure_info cc [] body
254 = -- thunks cannot have a primitive type!
255 getAbsC body_code `thenFC` \ body_absC ->
257 absC (CClosureInfoAndCode closure_info body_absC)
259 is_box = case body of { StgApp fun [] -> True; _ -> False }
261 ticky_ent_lit = if (isStaticClosure closure_info)
262 then FSLIT("TICK_ENT_STATIC_THK")
263 else FSLIT("TICK_ENT_DYN_THK")
265 body_code = profCtrC ticky_ent_lit [] `thenC`
266 -- node always points when profiling, so this is ok:
268 thunkWrapper closure_info (
269 -- We only enter cc after setting up update so
270 -- that cc of enclosing scope will be recorded
271 -- in update frame CAF/DICT functions will be
272 -- subsumed by this enclosing cc
273 enterCostCentreCode closure_info cc IsThunk is_box `thenC`
279 If there is /at least one argument/, then this closure is in
280 normal form, so there is no need to set up an update frame.
282 The Macros for GrAnSim are produced at the beginning of the
283 argSatisfactionCheck (by calling fetchAndReschedule). There info if
284 Node points to closure is available. -- HWL
287 closureCodeBody binder_info closure_info cc all_args body
288 = let arg_reps = map idPrimRep all_args in
290 getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
293 -- Arg mapping for the entry point; as many args as poss in
294 -- registers; the rest on the stack
295 -- arg_regs are the registers used for arg passing
296 -- stk_args are the args which are passed on the stack
298 -- Args passed on the stack are not tagged.
300 arg_regs = case entry_conv of
301 DirectEntry lbl arity regs -> regs
302 _ -> panic "closureCodeBody"
305 -- If this function doesn't have a specialised ArgDescr, we need
306 -- to generate the function's arg bitmap, slow-entry code, and
307 -- register-save code for the heap-check failure
309 (case closureFunInfo closure_info of
310 Just (_, ArgGen slow_lbl liveness) ->
311 absC (maybeLargeBitmap liveness) `thenC`
312 absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
313 returnFC (mkRegSaveCode arg_regs arg_reps)
315 other -> returnFC AbsCNop
317 `thenFC` \ reg_save_code ->
319 -- get the current virtual Sp (it might not be zero, eg. if we're
320 -- compiling a let-no-escape).
321 getVirtSp `thenFC` \vSp ->
324 (reg_args, stk_args) = splitAtList arg_regs all_args
326 (sp_stk_args, stk_offsets)
327 = mkVirtStkOffsets vSp idPrimRep stk_args
330 mod_name <- moduleName
331 profCtrC FSLIT("TICK_CTR") [
332 CLbl ticky_ctr_label DataPtrRep,
333 mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
334 mkIntCLit stg_arity, -- total # of args
335 mkIntCLit sp_stk_args, -- # passed on stk
336 mkCString (mkFastString (map (showTypeCategory . idType) all_args))
339 profCtrC ticky_ent_lit [
340 CLbl ticky_ctr_label DataPtrRep
343 -- Bind args to regs/stack as appropriate, and
344 -- record expected position of sps.
345 bindArgsToRegs reg_args arg_regs
346 mapCs bindNewToStack stk_offsets
347 setRealAndVirtualSp sp_stk_args
349 -- Enter the closures cc, if required
350 enterCostCentreCode closure_info cc IsFunction False
353 funWrapper closure_info arg_regs reg_save_code
354 (prof >> cgExpr body)
357 setTickyCtrLabel ticky_ctr_label (
359 forkAbsC entry_code `thenFC` \ entry_abs_c ->
360 moduleName `thenFC` \ mod_name ->
362 -- Now construct the info table
363 absC (CClosureInfoAndCode closure_info entry_abs_c)
366 ticky_ctr_label = mkRednCountsLabel name
369 if (isStaticClosure closure_info)
370 then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
371 else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
373 stg_arity = length all_args
374 lf_info = closureLFInfo closure_info
376 -- Manufacture labels
377 name = closureName closure_info
380 -- When printing the name of a thing in a ticky file, we want to
381 -- give the module name even for *local* things. We print
382 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
383 ppr_for_ticky_name mod_name name
384 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
385 | otherwise = showSDocDebug (ppr name)
388 The "slow entry" code for a function. This entry point takes its
389 arguments on the stack. It loads the arguments into registers
390 according to the calling convention, and jumps to the function's
391 normal entry point. The function's closure is assumed to be in
394 The slow entry point is used in two places:
396 (a) unknown calls: eg. stg_PAP_entry
397 (b) returning from a heap-check failure
400 mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
401 mkSlowEntryCode name lbl regs reps
403 mkAbstractCs [assts, stk_adj, jump]
406 stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
408 assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
409 mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
411 stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
412 stk_final_offset = head (drop (length regs) stk_offsets)
414 jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
416 mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
417 mkRegSaveCode regs reps
418 = mkAbstractCs [stk_adj, assts]
420 stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
422 stk_final_offset = head (drop (length regs) stk_offsets)
423 stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
425 assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
426 mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
429 For lexically scoped profiling we have to load the cost centre from
430 the closure entered, if the costs are not supposed to be inherited.
431 This is done immediately on entering the fast entry point.
433 Load current cost centre from closure, if not inherited.
434 Node is guaranteed to point to it, if profiling and not inherited.
437 data IsThunk = IsThunk | IsFunction -- Bool-like, local
443 :: ClosureInfo -> CostCentreStack
445 -> Bool -- is_box: this closure is a special box introduced by SCCfinal
448 enterCostCentreCode closure_info ccs is_thunk is_box
449 = if not opt_SccProfilingOn then
452 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
454 if isSubsumedCCS ccs then
455 ASSERT(isToplevClosure closure_info)
456 ASSERT(is_thunk == IsFunction)
457 costCentresC FSLIT("ENTER_CCS_FSUB") []
459 else if isDerivedFromCurrentCCS ccs then
460 if re_entrant && not is_box
461 then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
462 else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
464 else if isCafCCS ccs then
465 ASSERT(isToplevClosure closure_info)
466 ASSERT(is_thunk == IsThunk)
467 -- might be a PAP, in which case we want to subsume costs
469 then costCentresC FSLIT("ENTER_CCS_FSUB") []
470 else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
472 else panic "enterCostCentreCode"
475 c_ccs = [mkCCostCentreStack ccs]
476 re_entrant = closureReEntrant closure_info
479 %************************************************************************
481 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
483 %************************************************************************
486 thunkWrapper:: ClosureInfo -> Code -> Code
487 thunkWrapper closure_info thunk_code
488 = -- Stack and heap overflow checks
489 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
491 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
492 -- (we prefer fetchAndReschedule-style context switches to yield ones)
495 then fetchAndReschedule [] node_points
496 else yield [] node_points
497 else absC AbsCNop) `thenC`
500 | node_points = Nothing
501 | otherwise = Just (closureLabelFromCI closure_info)
504 -- stack and/or heap checks
505 thunkChecks closure_lbl (
507 -- Overwrite with black hole if necessary
508 blackHoleIt closure_info node_points `thenC`
510 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
512 -- Finally, do the business
516 funWrapper :: ClosureInfo -- Closure whose code body this is
517 -> [MagicId] -- List of argument registers (if any)
518 -> AbstractC -- reg saves for the heap check failure
519 -> Code -- Body of function being compiled
521 funWrapper closure_info arg_regs reg_save_code fun_body
522 = -- Stack overflow check
523 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
525 -- enter for Ldv profiling
526 (if node_points then ldvEnter else nopC) `thenC`
529 then yield arg_regs node_points
530 else absC AbsCNop) `thenC`
533 | node_points = Nothing
534 | otherwise = Just (closureLabelFromCI closure_info)
537 -- heap and/or stack checks
538 funEntryChecks closure_lbl reg_save_code (
540 -- Finally, do the business
546 %************************************************************************
548 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
550 %************************************************************************
554 blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
556 blackHoleIt closure_info node_points
557 = if blackHoleOnEntry closure_info && node_points
560 info_label = infoTableLabelFromCI closure_info
561 args = [ CLbl info_label DataPtrRep ]
563 absC (if closureSingleEntry(closure_info) then
564 CMacroStmt UPD_BH_SINGLE_ENTRY args
566 CMacroStmt UPD_BH_UPDATABLE args)
572 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
573 -- Nota Bene: this function does not change Node (even if it's a CAF),
574 -- so that the cost centre in the original closure can still be
575 -- extracted by a subsequent ENTER_CC_TCL
577 -- I've tidied up the code for this function, but it should still do the same as
578 -- it did before (modulo ticky stuff). KSW 1999-04.
579 setupUpdate closure_info code
580 = if closureReEntrant closure_info
584 case (closureUpdReqd closure_info, isStaticClosure closure_info) of
585 (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
587 (False,True ) -> (if opt_DoTickyProfiling
589 -- blackhole the SE CAF
590 link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
593 profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
594 profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
596 (True ,False) -> pushUpdateFrame (CReg node) code
597 (True ,True ) -> -- blackhole the (updatable) CAF:
598 link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
599 profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
600 pushUpdateFrame update_closure code
602 cl_name :: FastString
603 cl_name = (occNameFS . nameOccName . closureName) closure_info
605 link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
606 -> FCode CAddrMode -- Returns amode for closure to be updated
608 = -- To update a CAF we must allocate a black hole, link the CAF onto the
609 -- CAF list, then update the CAF to point to the fresh black hole.
610 -- This function returns the address of the black hole, so it can be
611 -- updated with the new value when available.
613 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
615 use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
618 allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
619 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
620 let amode = CAddr hp_rel
622 absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
626 %************************************************************************
628 \subsection[CgClosure-Description]{Profiling Closure Description.}
630 %************************************************************************
632 For "global" data constructors the description is simply occurrence
633 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
635 Otherwise it is determind by @closureDescription@ from the let
639 closureDescription :: Module -- Module
640 -> Name -- Id of closure binding
643 -- Not called for StgRhsCon which have global info tables built in
644 -- CgConTbls.lhs with a description generated from the data constructor
646 closureDescription mod_name name
656 chooseDynCostCentres ccs args fvs body
658 use_cc -- cost-centre we record in the object
659 = if currentOrSubsumedCCS ccs
660 then CReg CurCostCentre
661 else mkCCostCentreStack ccs
663 blame_cc -- cost-centre on whom we blame the allocation
664 = case (args, fvs, body) of
665 ([], _, StgApp fun [{-no args-}])
666 -> mkCCostCentreStack overheadCCS
669 -- if it's an utterly trivial RHS, then it must be
670 -- one introduced by boxHigherOrderArgs for profiling,
671 -- so we charge it to "OVERHEAD".
673 -- This looks like a HACK to me --SDM