2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 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,
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 Util ( isIn, splitAtList )
43 import CmdLineOpts ( opt_SccProfilingOn )
47 import Name ( nameOccName )
48 import OccName ( occNameFS )
50 -- Turgid imports for showTypeCategory
52 import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
53 import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
57 %********************************************************
59 \subsection[closures-no-free-vars]{Top-level closures}
61 %********************************************************
63 For closures bound at top level, allocate in static space.
64 They should have no free variables.
68 -> CostCentreStack -- Optional cost centre annotation
74 -> FCode (Id, CgIdInfo)
76 cgTopRhsClosure id ccs binder_info srt args body lf_info
82 getSRTInfo name srt `thenFC` \ srt_info ->
83 moduleName `thenFC` \ mod_name ->
86 descr = closureDescription mod_name name
87 closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
88 closure_label = mkClosureLabel name
89 cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
92 -- BUILD THE OBJECT (IF NECESSARY)
94 ({- if staticClosureRequired name binder_info lf_info
96 absC (mkStaticClosure closure_label closure_info ccs [] True)
102 -- GENERATE THE INFO TABLE (IF NECESSARY)
103 forkClosureBody (closureCodeBody binder_info closure_info
108 returnFC (id, cg_id_info)
112 %********************************************************
114 \subsection[non-top-level-closures]{Non top-level closures}
116 %********************************************************
118 For closures with free vars, allocate in heap.
123 -> CostCentreStack -- Optional cost centre annotation
129 -> [StgArg] -- payload
130 -> FCode (Id, CgIdInfo)
132 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
133 -- AHA! A STANDARD-FORM THUNK
135 -- LAY OUT THE OBJECT
136 getArgAmodes payload `thenFC` \ amodes ->
137 moduleName `thenFC` \ mod_name ->
139 descr = closureDescription mod_name (idName binder)
141 (closure_info, amodes_w_offsets)
142 = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
143 -- No SRT for a standard-form closure
145 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
149 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
151 `thenFC` \ heap_offset ->
154 returnFC (binder, heapIdInfo binder heap_offset lf_info)
157 Here's the general case.
161 -> CostCentreStack -- Optional cost centre annotation
168 -> FCode (Id, CgIdInfo)
170 cgRhsClosure binder cc binder_info srt fvs args body lf_info
172 -- LAY OUT THE OBJECT
174 -- If the binder is itself a free variable, then don't store
175 -- it in the closure. Instead, just bind it to Node on entry.
176 -- NB we can be sure that Node will point to it, because we
177 -- havn't told mkClosureLFInfo about this; so if the binder
178 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
179 -- stored in the closure itself, so it will make sure that
180 -- Node points to it...
182 is_elem = isIn "cgRhsClosure"
184 binder_is_a_fv = binder `is_elem` fvs
185 reduced_fvs = if binder_is_a_fv
186 then fvs `minusList` [binder]
192 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
193 getSRTInfo name srt `thenFC` \ srt_info ->
194 moduleName `thenFC` \ mod_name ->
196 descr = closureDescription mod_name (idName binder)
198 closure_info :: ClosureInfo
199 bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
201 (closure_info, bind_details)
202 = layOutDynClosure binder get_kind
203 fvs_w_amodes_and_info lf_info srt_info descr
205 bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
207 amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
209 get_kind (id, _, _) = idPrimRep id
212 -- BUILD ITS INFO TABLE AND CODE
215 mapCs bind_fv bind_details `thenC`
217 -- Bind the binder itself, if it is a free var
218 (if binder_is_a_fv then
219 bindNewToReg binder node lf_info
224 closureCodeBody binder_info closure_info cc args body
229 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
231 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
232 ) `thenFC` \ heap_offset ->
235 returnFC (binder, heapIdInfo binder heap_offset lf_info)
238 %************************************************************************
240 \subsection[code-for-closures]{The code for closures}
242 %************************************************************************
245 closureCodeBody :: StgBinderInfo
246 -> ClosureInfo -- Lots of information about this closure
247 -> CostCentreStack -- Optional cost centre attached to closure
253 There are two main cases for the code for closures. If there are {\em
254 no arguments}, then the closure is a thunk, and not in normal form.
255 So it should set up an update frame (if it is shared).
258 closureCodeBody binder_info closure_info cc [] body
259 = -- thunks cannot have a primitive type!
260 getAbsC body_code `thenFC` \ body_absC ->
262 absC (CClosureInfoAndCode closure_info body_absC)
264 is_box = case body of { StgApp fun [] -> True; _ -> False }
266 ticky_ent_lit = if (isStaticClosure closure_info)
267 then FSLIT("TICK_ENT_STATIC_THK")
268 else FSLIT("TICK_ENT_DYN_THK")
270 body_code = profCtrC ticky_ent_lit [] `thenC`
271 -- node always points when profiling, so this is ok:
273 thunkWrapper closure_info (
274 -- We only enter cc after setting up update so
275 -- that cc of enclosing scope will be recorded
276 -- in update frame CAF/DICT functions will be
277 -- subsumed by this enclosing cc
278 enterCostCentreCode closure_info cc IsThunk is_box `thenC`
284 If there is /at least one argument/, then this closure is in
285 normal form, so there is no need to set up an update frame.
287 The Macros for GrAnSim are produced at the beginning of the
288 argSatisfactionCheck (by calling fetchAndReschedule). There info if
289 Node points to closure is available. -- HWL
292 closureCodeBody binder_info closure_info cc all_args body
293 = let arg_reps = map idPrimRep all_args in
295 getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
298 -- Arg mapping for the entry point; as many args as poss in
299 -- registers; the rest on the stack
300 -- arg_regs are the registers used for arg passing
301 -- stk_args are the args which are passed on the stack
303 -- Args passed on the stack are not tagged.
305 arg_regs = case entry_conv of
306 DirectEntry lbl arity regs -> regs
307 _ -> panic "closureCodeBody"
310 -- If this function doesn't have a specialised ArgDescr, we need
311 -- to generate the function's arg bitmap, slow-entry code, and
312 -- register-save code for the heap-check failure
314 (case closureFunInfo closure_info of
315 Just (_, ArgGen slow_lbl liveness) ->
316 absC (maybeLargeBitmap liveness) `thenC`
317 absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
318 returnFC (mkRegSaveCode arg_regs arg_reps)
320 other -> returnFC AbsCNop
322 `thenFC` \ reg_save_code ->
324 -- get the current virtual Sp (it might not be zero, eg. if we're
325 -- compiling a let-no-escape).
326 getVirtSp `thenFC` \vSp ->
329 (reg_args, stk_args) = splitAtList arg_regs all_args
331 (sp_stk_args, stk_offsets)
332 = mkVirtStkOffsets vSp idPrimRep stk_args
335 mod_name <- moduleName
336 profCtrC FSLIT("TICK_CTR") [
337 CLbl ticky_ctr_label DataPtrRep,
338 mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
339 mkIntCLit stg_arity, -- total # of args
340 mkIntCLit sp_stk_args, -- # passed on stk
341 mkCString (mkFastString (map (showTypeCategory . idType) all_args))
344 profCtrC ticky_ent_lit [
345 CLbl ticky_ctr_label DataPtrRep
348 -- Bind args to regs/stack as appropriate, and
349 -- record expected position of sps.
350 bindArgsToRegs reg_args arg_regs
351 mapCs bindNewToStack stk_offsets
352 setRealAndVirtualSp sp_stk_args
354 -- Enter the closures cc, if required
355 enterCostCentreCode closure_info cc IsFunction False
358 funWrapper closure_info arg_regs reg_save_code
359 (prof >> cgExpr body)
362 setTickyCtrLabel ticky_ctr_label (
364 forkAbsC entry_code `thenFC` \ entry_abs_c ->
365 moduleName `thenFC` \ mod_name ->
367 -- Now construct the info table
368 absC (CClosureInfoAndCode closure_info entry_abs_c)
371 ticky_ctr_label = mkRednCountsLabel name
374 if (isStaticClosure closure_info)
375 then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
376 else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
378 stg_arity = length all_args
379 lf_info = closureLFInfo closure_info
381 -- Manufacture labels
382 name = closureName closure_info
385 -- When printing the name of a thing in a ticky file, we want to
386 -- give the module name even for *local* things. We print
387 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
388 ppr_for_ticky_name mod_name name
389 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
390 | otherwise = showSDocDebug (ppr name)
393 The "slow entry" code for a function. This entry point takes its
394 arguments on the stack. It loads the arguments into registers
395 according to the calling convention, and jumps to the function's
396 normal entry point. The function's closure is assumed to be in
399 The slow entry point is used in two places:
401 (a) unknown calls: eg. stg_PAP_entry
402 (b) returning from a heap-check failure
405 mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
406 mkSlowEntryCode name lbl regs reps
408 mkAbstractCs [assts, stk_adj, jump]
411 stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
413 assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
414 mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
416 stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
417 stk_final_offset = head (drop (length regs) stk_offsets)
419 jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
421 mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
422 mkRegSaveCode regs reps
423 = mkAbstractCs [stk_adj, assts]
425 stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
427 stk_final_offset = head (drop (length regs) stk_offsets)
428 stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
430 assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
431 mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
434 For lexically scoped profiling we have to load the cost centre from
435 the closure entered, if the costs are not supposed to be inherited.
436 This is done immediately on entering the fast entry point.
438 Load current cost centre from closure, if not inherited.
439 Node is guaranteed to point to it, if profiling and not inherited.
442 data IsThunk = IsThunk | IsFunction -- Bool-like, local
448 :: ClosureInfo -> CostCentreStack
450 -> Bool -- is_box: this closure is a special box introduced by SCCfinal
453 enterCostCentreCode closure_info ccs is_thunk is_box
454 = if not opt_SccProfilingOn then
457 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
459 if isSubsumedCCS ccs then
460 ASSERT(isToplevClosure closure_info)
461 ASSERT(is_thunk == IsFunction)
462 costCentresC FSLIT("ENTER_CCS_FSUB") []
464 else if isDerivedFromCurrentCCS ccs then
465 if re_entrant && not is_box
466 then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
467 else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
469 else if isCafCCS ccs then
470 ASSERT(isToplevClosure closure_info)
471 ASSERT(is_thunk == IsThunk)
472 -- might be a PAP, in which case we want to subsume costs
474 then costCentresC FSLIT("ENTER_CCS_FSUB") []
475 else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
477 else panic "enterCostCentreCode"
480 c_ccs = [mkCCostCentreStack ccs]
481 re_entrant = closureReEntrant closure_info
484 %************************************************************************
486 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
488 %************************************************************************
491 thunkWrapper:: ClosureInfo -> Code -> Code
492 thunkWrapper closure_info thunk_code
493 = -- Stack and heap overflow checks
494 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
496 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
497 -- (we prefer fetchAndReschedule-style context switches to yield ones)
500 then fetchAndReschedule [] node_points
501 else yield [] node_points
502 else absC AbsCNop) `thenC`
505 | node_points = Nothing
506 | otherwise = Just (closureLabelFromCI closure_info)
509 -- stack and/or heap checks
510 thunkChecks closure_lbl (
512 -- Overwrite with black hole if necessary
513 blackHoleIt closure_info node_points `thenC`
515 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
517 -- Finally, do the business
521 funWrapper :: ClosureInfo -- Closure whose code body this is
522 -> [MagicId] -- List of argument registers (if any)
523 -> AbstractC -- reg saves for the heap check failure
524 -> Code -- Body of function being compiled
526 funWrapper closure_info arg_regs reg_save_code fun_body
527 = -- Stack overflow check
528 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
530 -- enter for Ldv profiling
531 (if node_points then ldvEnter else nopC) `thenC`
534 then yield arg_regs node_points
535 else absC AbsCNop) `thenC`
538 | node_points = Nothing
539 | otherwise = Just (closureLabelFromCI closure_info)
542 -- heap and/or stack checks
543 funEntryChecks closure_lbl reg_save_code (
545 -- Finally, do the business
551 %************************************************************************
553 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
555 %************************************************************************
559 blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
561 blackHoleIt closure_info node_points
562 = if blackHoleOnEntry closure_info && node_points
565 info_label = infoTableLabelFromCI closure_info
566 args = [ CLbl info_label DataPtrRep ]
568 absC (if closureSingleEntry(closure_info) then
569 CMacroStmt UPD_BH_SINGLE_ENTRY args
571 CMacroStmt UPD_BH_UPDATABLE args)
577 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
578 -- Nota Bene: this function does not change Node (even if it's a CAF),
579 -- so that the cost centre in the original closure can still be
580 -- extracted by a subsequent ENTER_CC_TCL
582 -- I've tidied up the code for this function, but it should still do the same as
583 -- it did before (modulo ticky stuff). KSW 1999-04.
584 setupUpdate closure_info code
585 = if closureReEntrant closure_info
589 case (closureUpdReqd closure_info, isStaticClosure closure_info) of
590 (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
592 (False,True ) -> (if opt_DoTickyProfiling
594 -- blackhole the SE CAF
595 link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
598 profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
599 profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
601 (True ,False) -> pushUpdateFrame (CReg node) code
602 (True ,True ) -> -- blackhole the (updatable) CAF:
603 link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
604 profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
605 pushUpdateFrame update_closure code
607 cl_name :: FastString
608 cl_name = (occNameFS . nameOccName . closureName) closure_info
610 link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
611 -> FCode CAddrMode -- Returns amode for closure to be updated
613 = -- To update a CAF we must allocate a black hole, link the CAF onto the
614 -- CAF list, then update the CAF to point to the fresh black hole.
615 -- This function returns the address of the black hole, so it can be
616 -- updated with the new value when available.
618 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
620 use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
623 allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
624 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
625 let amode = CAddr hp_rel
627 absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
631 %************************************************************************
633 \subsection[CgClosure-Description]{Profiling Closure Description.}
635 %************************************************************************
637 For "global" data constructors the description is simply occurrence
638 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
640 Otherwise it is determind by @closureDescription@ from the let
644 closureDescription :: Module -- Module
645 -> Name -- Id of closure binding
648 -- Not called for StgRhsCon which have global info tables built in
649 -- CgConTbls.lhs with a description generated from the data constructor
651 closureDescription mod_name name
661 chooseDynCostCentres ccs args fvs body
663 use_cc -- cost-centre we record in the object
664 = if currentOrSubsumedCCS ccs
665 then CReg CurCostCentre
666 else mkCCostCentreStack ccs
668 blame_cc -- cost-centre on whom we blame the allocation
669 = case (args, fvs, body) of
670 ([], _, StgApp fun [{-no args-}])
671 -> mkCCostCentreStack overheadCCS
674 -- if it's an utterly trivial RHS, then it must be
675 -- one introduced by boxHigherOrderArgs for profiling,
676 -- so we charge it to "OVERHEAD".
678 -- This looks like a HACK to me --SDM
685 showTypeCategory :: Type -> Char
687 {C,I,F,D} char, int, float, double
689 S other single-constructor type
690 {c,i,f,d} unboxed ditto
692 s *unpacked" single-cons...
698 + dictionary, unless it's a ...
701 M other (multi-constructor) data-con type
703 - reserved for others to mark as "uninteresting"
709 case tcSplitTyConApp_maybe ty of
710 Nothing -> if isJust (tcSplitFunTy_maybe ty)
715 let utc = getUnique tycon in
716 if utc == charDataConKey then 'C'
717 else if utc == intDataConKey then 'I'
718 else if utc == floatDataConKey then 'F'
719 else if utc == doubleDataConKey then 'D'
720 else if utc == smallIntegerDataConKey ||
721 utc == largeIntegerDataConKey then 'J'
722 else if utc == charPrimTyConKey then 'c'
723 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
724 || utc == addrPrimTyConKey) then 'i'
725 else if utc == floatPrimTyConKey then 'f'
726 else if utc == doublePrimTyConKey then 'd'
727 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
728 else if isEnumerationTyCon tycon then 'E'
729 else if isTupleTyCon tycon then 'T'
730 else if isJust (maybeTyConSingleCon tycon) then 'S'
731 else if utc == listTyConKey then 'L'
732 else 'M' -- oh, well...