2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.48 2001/09/10 10:07:21 rje 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 )
26 import AbsCUtils ( mkAbstractCs, getAmodeRep )
27 import CgBindery ( getCAddrMode, getArgAmodes,
28 getCAddrModeAndInfo, bindNewToNode,
30 bindNewToReg, bindArgsToRegs,
31 stableAmodeIdInfo, heapIdInfo, CgIdInfo
33 import CgUpdate ( pushUpdateFrame )
34 import CgHeapery ( allocDynClosure,
35 fetchAndReschedule, yield, -- HWL
36 fastEntryChecks, thunkChecks
38 import CgStackery ( mkTaggedVirtStkOffsets, freeStackSlots )
39 import CgUsages ( adjustSpAndHp, setRealAndVirtualSp, getVirtSp,
40 getSpRelOffset, getHpRelOffset
42 import CLabel ( CLabel, mkClosureLabel, mkFastEntryLabel,
43 mkRednCountsLabel, mkInfoTableLabel
45 import ClosureInfo -- lots and lots of stuff
46 import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
48 import Id ( Id, idName, idType, idPrimRep )
49 import Name ( Name, isLocalName )
50 import Module ( Module, pprModule )
51 import ListSetOps ( minusList )
52 import PrimRep ( PrimRep(..) )
53 import PprType ( showTypeCategory )
55 import CmdLineOpts ( opt_SccProfilingOn )
58 import Name ( nameOccName )
59 import OccName ( occNameFS )
60 import FastTypes ( iBox )
63 %********************************************************
65 \subsection[closures-no-free-vars]{Top-level closures}
67 %********************************************************
69 For closures bound at top level, allocate in static space.
70 They should have no free variables.
74 -> CostCentreStack -- Optional cost centre annotation
79 -> FCode (Id, CgIdInfo)
81 cgTopRhsClosure id ccs binder_info args body lf_info
86 closure_info = layOutStaticNoFVClosure name lf_info
87 closure_label = mkClosureLabel name
88 cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
91 -- BUILD THE OBJECT (IF NECESSARY)
92 ({- if staticClosureRequired name binder_info lf_info
94 (if opt_SccProfilingOn
97 closure_label -- Labelled with the name on lhs of defn
99 (mkCCostCentreStack ccs)
103 closure_label -- Labelled with the name on lhs of defn
113 -- GENERATE THE INFO TABLE (IF NECESSARY)
114 forkClosureBody (closureCodeBody binder_info closure_info
119 returnFC (id, cg_id_info)
123 %********************************************************
125 \subsection[non-top-level-closures]{Non top-level closures}
127 %********************************************************
129 For closures with free vars, allocate in heap.
134 -> CostCentreStack -- Optional cost centre annotation
140 -> [StgArg] -- payload
141 -> FCode (Id, CgIdInfo)
143 cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
144 -- AHA! A STANDARD-FORM THUNK
146 -- LAY OUT THE OBJECT
147 getArgAmodes payload `thenFC` \ amodes ->
149 (closure_info, amodes_w_offsets)
150 = layOutDynClosure (idName binder) getAmodeRep amodes lf_info
152 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
155 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
157 `thenFC` \ heap_offset ->
160 returnFC (binder, heapIdInfo binder heap_offset lf_info)
163 Here's the general case.
167 -> CostCentreStack -- Optional cost centre annotation
173 -> FCode (Id, CgIdInfo)
175 cgRhsClosure binder cc binder_info fvs args body lf_info
177 -- LAY OUT THE OBJECT
179 -- If the binder is itself a free variable, then don't store
180 -- it in the closure. Instead, just bind it to Node on entry.
181 -- NB we can be sure that Node will point to it, because we
182 -- havn't told mkClosureLFInfo about this; so if the binder
183 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
184 -- stored in the closure itself, so it will make sure that
185 -- Node points to it...
187 is_elem = isIn "cgRhsClosure"
189 binder_is_a_fv = binder `is_elem` fvs
190 reduced_fvs = if binder_is_a_fv
191 then fvs `minusList` [binder]
194 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
196 closure_info :: ClosureInfo
197 bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
199 (closure_info, bind_details)
200 = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
202 bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
204 amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
206 get_kind (id, _, _) = idPrimRep id
208 -- BUILD ITS INFO TABLE AND CODE
211 mapCs bind_fv bind_details `thenC`
213 -- Bind the binder itself, if it is a free var
214 (if binder_is_a_fv then
215 bindNewToReg binder node lf_info
220 closureCodeBody binder_info closure_info cc args body
225 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
227 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
228 ) `thenFC` \ heap_offset ->
231 returnFC (binder, heapIdInfo binder heap_offset lf_info)
234 %************************************************************************
236 \subsection[code-for-closures]{The code for closures}
238 %************************************************************************
241 closureCodeBody :: StgBinderInfo
242 -> ClosureInfo -- Lots of information about this closure
243 -> CostCentreStack -- Optional cost centre attached to closure
249 There are two main cases for the code for closures. If there are {\em
250 no arguments}, then the closure is a thunk, and not in normal form.
251 So it should set up an update frame (if it is shared). Also, it has
252 no argument satisfaction check, so fast and slow entry-point labels
256 closureCodeBody binder_info closure_info cc [] body
257 = -- thunks cannot have a primitive type!
258 getAbsC body_code `thenFC` \ body_absC ->
259 moduleName `thenFC` \ mod_name ->
261 absC (CClosureInfoAndCode closure_info body_absC Nothing
264 cl_descr mod_name = closureDescription mod_name (closureName closure_info)
266 body_label = entryLabelFromCI closure_info
268 is_box = case body of { StgApp fun [] -> True; _ -> False }
270 body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
271 thunkWrapper closure_info body_label (
272 -- We only enter cc after setting up update so that cc
273 -- of enclosing scope will be recorded in update frame
274 -- CAF/DICT functions will be subsumed by this enclosing cc
275 enterCostCentreCode closure_info cc IsThunk is_box `thenC`
279 If there is {\em at least one argument}, then this closure is in
280 normal form, so there is no need to set up an update frame. On the
281 other hand, we do have to check that there are enough args, and
282 perform an update if not!
284 The Macros for GrAnSim are produced at the beginning of the
285 argSatisfactionCheck (by calling fetchAndReschedule). There info if
286 Node points to closure is available. -- HWL
289 closureCodeBody binder_info closure_info cc all_args body
290 = getEntryConvention name lf_info
291 (map idPrimRep all_args) `thenFC` \ entry_conv ->
293 -- get the current virtual Sp (it might not be zero, eg. if we're
294 -- compiling a let-no-escape).
295 getVirtSp `thenFC` \vSp ->
298 -- Figure out what is needed and what isn't
300 -- SDM: need everything for now in case the heap/stack check refers
302 slow_code_needed = True
303 --slowFunEntryCodeRequired name binder_info entry_conv
304 info_table_needed = True
305 --funInfoTableRequired name binder_info lf_info
307 -- Arg mapping for standard (slow) entry point; all args on stack,
309 (sp_all_args, arg_offsets, _)
310 = mkTaggedVirtStkOffsets vSp idPrimRep all_args
312 -- Arg mapping for the fast entry point; as many args as poss in
313 -- registers; the rest on the stack
314 -- arg_regs are the registers used for arg passing
315 -- stk_args are the args which are passed on the stack
317 -- Args passed on the stack are tagged, but the tags may not
318 -- actually be present (just gaps) if the function is called
319 -- by jumping directly to the fast entry point.
321 arg_regs = case entry_conv of
322 DirectEntry lbl arity regs -> regs
323 other -> [] -- "(HWL ignored; no args passed in regs)"
325 num_arg_regs = length arg_regs
327 (reg_args, stk_args) = splitAt num_arg_regs all_args
329 (sp_stk_args, stk_offsets, stk_tags)
330 = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
332 -- HWL; Note: empty list of live regs in slow entry code
333 -- Old version (reschedule combined with heap check);
334 -- see argSatisfactionCheck for new version
335 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
336 -- where node = UnusedReg PtrRep 1
337 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
340 = profCtrC SLIT("TICK_ENT_FUN_STD") [
341 CLbl ticky_ctr_label DataPtrRep
344 -- Bind args, and record expected position of stk ptrs
345 mapCs bindNewToStack arg_offsets `thenC`
346 setRealAndVirtualSp sp_all_args `thenC`
348 argSatisfactionCheck closure_info arg_regs `thenC`
350 -- OK, so there are enough args. Now we need to stuff as
351 -- many of them in registers as the fast-entry code
352 -- expects. Note that the zipWith will give up when it hits
353 -- the end of arg_regs.
355 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
356 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
359 -- Now adjust real stack pointers (no need to adjust Hp,
360 -- but call this function for convenience).
361 adjustSpAndHp 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 mod_name <- moduleName
374 profCtrC SLIT("TICK_CTR") [
375 CLbl ticky_ctr_label DataPtrRep,
376 mkCString (_PK_ (ppr_for_ticky_name mod_name name)),
377 mkIntCLit stg_arity, -- total # of args
378 mkIntCLit sp_stk_args, -- # passed on stk
379 mkCString (_PK_ (map (showTypeCategory . idType) all_args))
382 profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
383 CLbl ticky_ctr_label DataPtrRep
386 -- Nuked for now; see comment at end of file
387 -- CString (_PK_ (show_wrapper_name wrapper_maybe)),
388 -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
391 -- Bind args to regs/stack as appropriate, and
392 -- record expected position of sps.
393 bindArgsToRegs reg_args arg_regs
394 mapCs bindNewToStack stk_offsets
395 setRealAndVirtualSp sp_stk_args
397 -- free up the stack slots containing tags
398 freeStackSlots (map fst stk_tags)
400 -- Enter the closures cc, if required
401 enterCostCentreCode closure_info cc IsFunction False
404 funWrapper closure_info arg_regs stk_tags info_label
405 (prof >> cgExpr body)
408 setTickyCtrLabel ticky_ctr_label (
410 -- Make a labelled code-block for the slow and fast entry code
411 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
412 `thenFC` \ slow_abs_c ->
413 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
414 moduleName `thenFC` \ mod_name ->
416 -- Now either construct the info table, or put the fast code in alone
417 -- (We never have slow code without an info table)
418 -- XXX probably need the info table and slow entry code in case of
419 -- a heap check failure.
421 if info_table_needed then
422 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
425 CCodeBlock fast_label fast_abs_c
429 ticky_ctr_label = mkRednCountsLabel name
431 stg_arity = length all_args
432 lf_info = closureLFInfo closure_info
434 cl_descr mod_name = closureDescription mod_name name
436 -- Manufacture labels
437 name = closureName closure_info
438 fast_label = mkFastEntryLabel name stg_arity
439 info_label = mkInfoTableLabel name
442 -- When printing the name of a thing in a ticky file, we want to
443 -- give the module name even for *local* things. We print
444 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
445 ppr_for_ticky_name mod_name name
446 | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
447 | otherwise = showSDocDebug (ppr name)
450 For lexically scoped profiling we have to load the cost centre from
451 the closure entered, if the costs are not supposed to be inherited.
452 This is done immediately on entering the fast entry point.
454 Load current cost centre from closure, if not inherited.
455 Node is guaranteed to point to it, if profiling and not inherited.
458 data IsThunk = IsThunk | IsFunction -- Bool-like, local
464 :: ClosureInfo -> CostCentreStack
466 -> Bool -- is_box: this closure is a special box introduced by SCCfinal
469 enterCostCentreCode closure_info ccs is_thunk is_box
470 = if not opt_SccProfilingOn then
473 ASSERT(not (noCCSAttached ccs))
475 if isSubsumedCCS ccs then
476 ASSERT(isToplevClosure closure_info)
477 ASSERT(is_thunk == IsFunction)
478 costCentresC SLIT("ENTER_CCS_FSUB") []
480 else if isCurrentCCS ccs then
481 if re_entrant && not is_box
482 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
483 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
485 else if isCafCCS ccs then
486 ASSERT(isToplevClosure closure_info)
487 ASSERT(is_thunk == IsThunk)
488 -- might be a PAP, in which case we want to subsume costs
490 then costCentresC SLIT("ENTER_CCS_FSUB") []
491 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
493 else panic "enterCostCentreCode"
496 c_ccs = [mkCCostCentreStack ccs]
497 re_entrant = closureReEntrant closure_info
500 %************************************************************************
502 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
504 %************************************************************************
506 The argument-satisfaction check code is placed after binding
507 the arguments to their stack locations. Hence, the virtual stack
508 pointer is pointing after all the args, and virtual offset 1 means
509 the base of frame and hence most distant arg. Hence
510 virtual offset 0 is just beyond the most distant argument; the
511 relative offset of this word tells how many words of arguments
515 argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
517 argSatisfactionCheck closure_info arg_regs
519 = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
522 -- emit_gran_macros = opt_GranMacros
526 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
527 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
529 -- then if node_points
530 -- then fetchAndReschedule arg_regs node_points
531 -- else yield arg_regs node_points
532 -- else absC AbsCNop) `thenC`
534 getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
537 rel_arg = mkIntCLit off
541 absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
543 absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
545 -- We must tell the arg-satis macro whether Node is pointing to
546 -- the closure or not. If it isn't so pointing, then we give to
547 -- the macro the (static) address of the closure.
549 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
552 %************************************************************************
554 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
556 %************************************************************************
559 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
560 thunkWrapper closure_info lbl thunk_code
561 = -- Stack and heap overflow checks
562 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
564 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
565 -- (we prefer fetchAndReschedule-style context switches to yield ones)
568 then fetchAndReschedule [] node_points
569 else yield [] node_points
570 else absC AbsCNop) `thenC`
572 -- stack and/or heap checks
573 thunkChecks lbl node_points (
575 -- Overwrite with black hole if necessary
576 blackHoleIt closure_info node_points `thenC`
578 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
580 -- Finally, do the business
584 funWrapper :: ClosureInfo -- Closure whose code body this is
585 -> [MagicId] -- List of argument registers (if any)
586 -> [(VirtualSpOffset,Int)] -- tagged stack slots
587 -> CLabel -- info table for heap check ret.
588 -> Code -- Body of function being compiled
590 funWrapper closure_info arg_regs stk_tags info_label fun_body
591 = -- Stack overflow check
592 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
595 then yield arg_regs node_points
596 else absC AbsCNop) `thenC`
598 -- heap and/or stack checks
599 fastEntryChecks arg_regs stk_tags info_label node_points (
601 -- Finally, do the business
607 %************************************************************************
609 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
611 %************************************************************************
615 blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
617 blackHoleIt closure_info node_points
618 = if blackHoleOnEntry closure_info && node_points
621 info_label = infoTableLabelFromCI closure_info
622 args = [ CLbl info_label DataPtrRep ]
624 absC (if closureSingleEntry(closure_info) then
625 CMacroStmt UPD_BH_SINGLE_ENTRY args
627 CMacroStmt UPD_BH_UPDATABLE args)
633 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
634 -- Nota Bene: this function does not change Node (even if it's a CAF),
635 -- so that the cost centre in the original closure can still be
636 -- extracted by a subsequent ENTER_CC_TCL
638 -- I've tidied up the code for this function, but it should still do the same as
639 -- it did before (modulo ticky stuff). KSW 1999-04.
640 setupUpdate closure_info code
641 = if closureReEntrant closure_info
645 case (closureUpdReqd closure_info, isStaticClosure closure_info) of
646 (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
648 (False,True ) -> (if opt_DoTickyProfiling
650 -- blackhole the SE CAF
651 link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
654 profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
655 profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
657 (True ,False) -> pushUpdateFrame (CReg node) code
658 (True ,True ) -> -- blackhole the (updatable) CAF:
659 link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
660 profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
661 pushUpdateFrame update_closure code
663 cl_name :: FAST_STRING
664 cl_name = (occNameFS . nameOccName . closureName) closure_info
666 link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
667 -> FCode CAddrMode -- Returns amode for closure to be updated
669 = -- To update a CAF we must allocate a black hole, link the CAF onto the
670 -- CAF list, then update the CAF to point to the fresh black hole.
671 -- This function returns the address of the black hole, so it can be
672 -- updated with the new value when available.
674 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
676 use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
679 allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
680 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
681 let amode = CAddr hp_rel
683 absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
687 %************************************************************************
689 \subsection[CgClosure-Description]{Profiling Closure Description.}
691 %************************************************************************
693 For "global" data constructors the description is simply occurrence
694 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
696 Otherwise it is determind by @closureDescription@ from the let
700 closureDescription :: Module -- Module
701 -> Name -- Id of closure binding
704 -- Not called for StgRhsCon which have global info tables built in
705 -- CgConTbls.lhs with a description generated from the data constructor
707 closureDescription mod_name name
717 chooseDynCostCentres ccs args fvs body
719 use_cc -- cost-centre we record in the object
720 = if currentOrSubsumedCCS ccs
721 then CReg CurCostCentre
722 else mkCCostCentreStack ccs
724 blame_cc -- cost-centre on whom we blame the allocation
725 = case (args, fvs, body) of
726 ([], _, StgApp fun [{-no args-}])
727 -> mkCCostCentreStack overheadCCS
730 -- if it's an utterly trivial RHS, then it must be
731 -- one introduced by boxHigherOrderArgs for profiling,
732 -- so we charge it to "OVERHEAD".
734 -- This looks like a HACK to me --SDM