2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.59 2002/12/11 15:36:25 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
74 getSRTInfo srt `thenFC` \ srt_info ->
75 moduleName `thenFC` \ mod_name ->
78 descr = closureDescription mod_name name
79 closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
80 closure_label = mkClosureLabel name
81 cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
84 -- BUILD THE OBJECT (IF NECESSARY)
86 ({- if staticClosureRequired name binder_info lf_info
88 absC (mkStaticClosure closure_label closure_info ccs [] True)
94 -- GENERATE THE INFO TABLE (IF NECESSARY)
95 forkClosureBody (closureCodeBody binder_info closure_info
100 returnFC (id, cg_id_info)
104 %********************************************************
106 \subsection[non-top-level-closures]{Non top-level closures}
108 %********************************************************
110 For closures with free vars, allocate in heap.
115 -> CostCentreStack -- Optional cost centre annotation
121 -> [StgArg] -- payload
122 -> FCode (Id, CgIdInfo)
124 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
125 -- AHA! A STANDARD-FORM THUNK
127 -- LAY OUT THE OBJECT
128 getArgAmodes payload `thenFC` \ amodes ->
129 moduleName `thenFC` \ mod_name ->
131 descr = closureDescription mod_name (idName binder)
133 (closure_info, amodes_w_offsets)
134 = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
135 -- No SRT for a standard-form closure
137 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
141 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
143 `thenFC` \ heap_offset ->
146 returnFC (binder, heapIdInfo binder heap_offset lf_info)
149 Here's the general case.
153 -> CostCentreStack -- Optional cost centre annotation
160 -> FCode (Id, CgIdInfo)
162 cgRhsClosure binder cc binder_info srt fvs args body lf_info
164 -- LAY OUT THE OBJECT
166 -- If the binder is itself a free variable, then don't store
167 -- it in the closure. Instead, just bind it to Node on entry.
168 -- NB we can be sure that Node will point to it, because we
169 -- havn't told mkClosureLFInfo about this; so if the binder
170 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
171 -- stored in the closure itself, so it will make sure that
172 -- Node points to it...
174 is_elem = isIn "cgRhsClosure"
176 binder_is_a_fv = binder `is_elem` fvs
177 reduced_fvs = if binder_is_a_fv
178 then fvs `minusList` [binder]
182 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
183 getSRTInfo srt `thenFC` \ srt_info ->
184 moduleName `thenFC` \ mod_name ->
186 descr = closureDescription mod_name (idName binder)
188 closure_info :: ClosureInfo
189 bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
191 (closure_info, bind_details)
192 = layOutDynClosure binder get_kind
193 fvs_w_amodes_and_info lf_info srt_info descr
195 bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
197 amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
199 get_kind (id, _, _) = idPrimRep id
202 -- BUILD ITS INFO TABLE AND CODE
205 mapCs bind_fv bind_details `thenC`
207 -- Bind the binder itself, if it is a free var
208 (if binder_is_a_fv then
209 bindNewToReg binder node lf_info
214 closureCodeBody binder_info closure_info cc args body
219 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
221 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
222 ) `thenFC` \ heap_offset ->
225 returnFC (binder, heapIdInfo binder heap_offset lf_info)
228 %************************************************************************
230 \subsection[code-for-closures]{The code for closures}
232 %************************************************************************
235 closureCodeBody :: StgBinderInfo
236 -> ClosureInfo -- Lots of information about this closure
237 -> CostCentreStack -- Optional cost centre attached to closure
243 There are two main cases for the code for closures. If there are {\em
244 no arguments}, then the closure is a thunk, and not in normal form.
245 So it should set up an update frame (if it is shared).
248 closureCodeBody binder_info closure_info cc [] body
249 = -- thunks cannot have a primitive type!
250 getAbsC body_code `thenFC` \ body_absC ->
252 absC (CClosureInfoAndCode closure_info body_absC)
254 is_box = case body of { StgApp fun [] -> True; _ -> False }
256 ticky_ent_lit = if (isStaticClosure closure_info)
257 then FSLIT("TICK_ENT_STATIC_THK")
258 else FSLIT("TICK_ENT_DYN_THK")
260 body_code = profCtrC ticky_ent_lit [] `thenC`
261 -- node always points when profiling, so this is ok:
263 thunkWrapper closure_info (
264 -- We only enter cc after setting up update so
265 -- that cc of enclosing scope will be recorded
266 -- in update frame CAF/DICT functions will be
267 -- subsumed by this enclosing cc
268 enterCostCentreCode closure_info cc IsThunk is_box `thenC`
274 If there is /at least one argument/, then this closure is in
275 normal form, so there is no need to set up an update frame.
277 The Macros for GrAnSim are produced at the beginning of the
278 argSatisfactionCheck (by calling fetchAndReschedule). There info if
279 Node points to closure is available. -- HWL
282 closureCodeBody binder_info closure_info cc all_args body
283 = let arg_reps = map idPrimRep all_args in
285 getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
288 -- Arg mapping for the entry point; as many args as poss in
289 -- registers; the rest on the stack
290 -- arg_regs are the registers used for arg passing
291 -- stk_args are the args which are passed on the stack
293 -- Args passed on the stack are not tagged.
295 arg_regs = case entry_conv of
296 DirectEntry lbl arity regs -> regs
297 _ -> panic "closureCodeBody"
300 -- If this function doesn't have a specialised ArgDescr, we need
301 -- to generate the function's arg bitmap, slow-entry code, and
302 -- register-save code for the heap-check failure
304 (case closureFunInfo closure_info of
305 Just (_, ArgGen slow_lbl liveness) ->
306 absC (CBitmap liveness) `thenC`
307 absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
308 returnFC (mkRegSaveCode arg_regs arg_reps)
310 other -> returnFC AbsCNop
312 `thenFC` \ reg_save_code ->
314 -- get the current virtual Sp (it might not be zero, eg. if we're
315 -- compiling a let-no-escape).
316 getVirtSp `thenFC` \vSp ->
319 (reg_args, stk_args) = splitAtList arg_regs all_args
321 (sp_stk_args, stk_offsets)
322 = mkVirtStkOffsets vSp idPrimRep stk_args
325 mod_name <- moduleName
326 profCtrC FSLIT("TICK_CTR") [
327 CLbl ticky_ctr_label DataPtrRep,
328 mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
329 mkIntCLit stg_arity, -- total # of args
330 mkIntCLit sp_stk_args, -- # passed on stk
331 mkCString (mkFastString (map (showTypeCategory . idType) all_args))
334 profCtrC ticky_ent_lit [
335 CLbl ticky_ctr_label DataPtrRep
338 -- Bind args to regs/stack as appropriate, and
339 -- record expected position of sps.
340 bindArgsToRegs reg_args arg_regs
341 mapCs bindNewToStack stk_offsets
342 setRealAndVirtualSp sp_stk_args
344 -- Enter the closures cc, if required
345 enterCostCentreCode closure_info cc IsFunction False
348 funWrapper closure_info arg_regs reg_save_code
349 (prof >> cgExpr body)
352 setTickyCtrLabel ticky_ctr_label (
354 forkAbsC entry_code `thenFC` \ entry_abs_c ->
355 moduleName `thenFC` \ mod_name ->
357 -- Now construct the info table
358 absC (CClosureInfoAndCode closure_info entry_abs_c)
361 ticky_ctr_label = mkRednCountsLabel name
364 if (isStaticClosure closure_info)
365 then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
366 else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
368 stg_arity = length all_args
369 lf_info = closureLFInfo closure_info
371 -- Manufacture labels
372 name = closureName closure_info
375 -- When printing the name of a thing in a ticky file, we want to
376 -- give the module name even for *local* things. We print
377 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
378 ppr_for_ticky_name mod_name name
379 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
380 | otherwise = showSDocDebug (ppr name)
383 The "slow entry" code for a function. This entry point takes its
384 arguments on the stack. It loads the arguments into registers
385 according to the calling convention, and jumps to the function's
386 normal entry point. The function's closure is assumed to be in
389 The slow entry point is used in two places:
391 (a) unknown calls: eg. stg_PAP_entry
392 (b) returning from a heap-check failure
395 mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
396 mkSlowEntryCode name lbl regs reps
398 mkAbstractCs [assts, stk_adj, jump]
401 stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
403 assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
404 mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
406 stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
407 stk_final_offset = head (drop (length regs) stk_offsets)
409 jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
411 mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
412 mkRegSaveCode regs reps
413 = mkAbstractCs [stk_adj, assts]
415 stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
417 stk_final_offset = head (drop (length regs) stk_offsets)
418 stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
420 assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
421 mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
424 For lexically scoped profiling we have to load the cost centre from
425 the closure entered, if the costs are not supposed to be inherited.
426 This is done immediately on entering the fast entry point.
428 Load current cost centre from closure, if not inherited.
429 Node is guaranteed to point to it, if profiling and not inherited.
432 data IsThunk = IsThunk | IsFunction -- Bool-like, local
438 :: ClosureInfo -> CostCentreStack
440 -> Bool -- is_box: this closure is a special box introduced by SCCfinal
443 enterCostCentreCode closure_info ccs is_thunk is_box
444 = if not opt_SccProfilingOn then
447 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
449 if isSubsumedCCS ccs then
450 ASSERT(isToplevClosure closure_info)
451 ASSERT(is_thunk == IsFunction)
452 costCentresC FSLIT("ENTER_CCS_FSUB") []
454 else if isDerivedFromCurrentCCS ccs then
455 if re_entrant && not is_box
456 then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
457 else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
459 else if isCafCCS ccs then
460 ASSERT(isToplevClosure closure_info)
461 ASSERT(is_thunk == IsThunk)
462 -- might be a PAP, in which case we want to subsume costs
464 then costCentresC FSLIT("ENTER_CCS_FSUB") []
465 else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
467 else panic "enterCostCentreCode"
470 c_ccs = [mkCCostCentreStack ccs]
471 re_entrant = closureReEntrant closure_info
474 %************************************************************************
476 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
478 %************************************************************************
481 thunkWrapper:: ClosureInfo -> Code -> Code
482 thunkWrapper closure_info thunk_code
483 = -- Stack and heap overflow checks
484 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
486 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
487 -- (we prefer fetchAndReschedule-style context switches to yield ones)
490 then fetchAndReschedule [] node_points
491 else yield [] node_points
492 else absC AbsCNop) `thenC`
495 | node_points = Nothing
496 | otherwise = Just (closureLabelFromCI closure_info)
499 -- stack and/or heap checks
500 thunkChecks closure_lbl (
502 -- Overwrite with black hole if necessary
503 blackHoleIt closure_info node_points `thenC`
505 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
507 -- Finally, do the business
511 funWrapper :: ClosureInfo -- Closure whose code body this is
512 -> [MagicId] -- List of argument registers (if any)
513 -> AbstractC -- reg saves for the heap check failure
514 -> Code -- Body of function being compiled
516 funWrapper closure_info arg_regs reg_save_code fun_body
517 = -- Stack overflow check
518 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
520 -- enter for Ldv profiling
521 (if node_points then ldvEnter else nopC) `thenC`
524 then yield arg_regs node_points
525 else absC AbsCNop) `thenC`
528 | node_points = Nothing
529 | otherwise = Just (closureLabelFromCI closure_info)
532 -- heap and/or stack checks
533 funEntryChecks closure_lbl reg_save_code (
535 -- Finally, do the business
541 %************************************************************************
543 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
545 %************************************************************************
549 blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
551 blackHoleIt closure_info node_points
552 = if blackHoleOnEntry closure_info && node_points
555 info_label = infoTableLabelFromCI closure_info
556 args = [ CLbl info_label DataPtrRep ]
558 absC (if closureSingleEntry(closure_info) then
559 CMacroStmt UPD_BH_SINGLE_ENTRY args
561 CMacroStmt UPD_BH_UPDATABLE args)
567 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
568 -- Nota Bene: this function does not change Node (even if it's a CAF),
569 -- so that the cost centre in the original closure can still be
570 -- extracted by a subsequent ENTER_CC_TCL
572 -- I've tidied up the code for this function, but it should still do the same as
573 -- it did before (modulo ticky stuff). KSW 1999-04.
574 setupUpdate closure_info code
575 = if closureReEntrant closure_info
579 case (closureUpdReqd closure_info, isStaticClosure closure_info) of
580 (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
582 (False,True ) -> (if opt_DoTickyProfiling
584 -- blackhole the SE CAF
585 link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
588 profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
589 profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
591 (True ,False) -> pushUpdateFrame (CReg node) code
592 (True ,True ) -> -- blackhole the (updatable) CAF:
593 link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
594 profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
595 pushUpdateFrame update_closure code
597 cl_name :: FastString
598 cl_name = (occNameFS . nameOccName . closureName) closure_info
600 link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
601 -> FCode CAddrMode -- Returns amode for closure to be updated
603 = -- To update a CAF we must allocate a black hole, link the CAF onto the
604 -- CAF list, then update the CAF to point to the fresh black hole.
605 -- This function returns the address of the black hole, so it can be
606 -- updated with the new value when available.
608 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
610 use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
613 allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
614 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
615 let amode = CAddr hp_rel
617 absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
621 %************************************************************************
623 \subsection[CgClosure-Description]{Profiling Closure Description.}
625 %************************************************************************
627 For "global" data constructors the description is simply occurrence
628 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
630 Otherwise it is determind by @closureDescription@ from the let
634 closureDescription :: Module -- Module
635 -> Name -- Id of closure binding
638 -- Not called for StgRhsCon which have global info tables built in
639 -- CgConTbls.lhs with a description generated from the data constructor
641 closureDescription mod_name name
651 chooseDynCostCentres ccs args fvs body
653 use_cc -- cost-centre we record in the object
654 = if currentOrSubsumedCCS ccs
655 then CReg CurCostCentre
656 else mkCCostCentreStack ccs
658 blame_cc -- cost-centre on whom we blame the allocation
659 = case (args, fvs, body) of
660 ([], _, StgApp fun [{-no args-}])
661 -> mkCCostCentreStack overheadCCS
664 -- if it's an utterly trivial RHS, then it must be
665 -- one introduced by boxHigherOrderArgs for profiling,
666 -- so we charge it to "OVERHEAD".
668 -- This looks like a HACK to me --SDM