2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.43 2000/11/06 08:15:21 simonpj 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
82 = -- LAY OUT THE OBJECT
84 closure_info = layOutStaticNoFVClosure name lf_info
87 -- BUILD THE OBJECT (IF NECESSARY)
88 ({- if staticClosureRequired name binder_info lf_info
90 (if opt_SccProfilingOn
93 closure_label -- Labelled with the name on lhs of defn
95 (mkCCostCentreStack ccs)
99 closure_label -- Labelled with the name on lhs of defn
109 -- GENERATE THE INFO TABLE (IF NECESSARY)
110 forkClosureBody (closureCodeBody binder_info closure_info
115 returnFC (id, cg_id_info)
118 closure_label = mkClosureLabel name
119 cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
122 %********************************************************
124 \subsection[non-top-level-closures]{Non top-level closures}
126 %********************************************************
128 For closures with free vars, allocate in heap.
133 -> CostCentreStack -- Optional cost centre annotation
139 -> [StgArg] -- payload
140 -> FCode (Id, CgIdInfo)
142 cgStdRhsClosure binder cc binder_info 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 Here's the general case.
166 -> CostCentreStack -- Optional cost centre annotation
172 -> FCode (Id, CgIdInfo)
174 cgRhsClosure binder cc binder_info fvs args body lf_info
176 -- LAY OUT THE OBJECT
178 -- If the binder is itself a free variable, then don't store
179 -- it in the closure. Instead, just bind it to Node on entry.
180 -- NB we can be sure that Node will point to it, because we
181 -- havn't told mkClosureLFInfo about this; so if the binder
182 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
183 -- stored in the closure itself, so it will make sure that
184 -- Node points to it...
186 is_elem = isIn "cgRhsClosure"
188 binder_is_a_fv = binder `is_elem` fvs
189 reduced_fvs = if binder_is_a_fv
190 then fvs `minusList` [binder]
193 mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ amodes_and_info ->
195 fvs_w_amodes_and_info = reduced_fvs `zip` amodes_and_info
197 closure_info :: ClosureInfo
198 bind_details :: [((Id, (CAddrMode, LambdaFormInfo)), VirtualHeapOffset)]
200 (closure_info, bind_details)
201 = layOutDynClosure (idName binder) get_kind fvs_w_amodes_and_info lf_info
203 bind_fv ((id, (_, lf_info)), offset) = bindNewToNode id offset lf_info
205 amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
207 get_kind (id, amode_and_info) = idPrimRep id
209 -- BUILD ITS INFO TABLE AND CODE
212 mapCs bind_fv bind_details `thenC`
214 -- Bind the binder itself, if it is a free var
215 (if binder_is_a_fv then
216 bindNewToReg binder node lf_info
221 closureCodeBody binder_info closure_info cc args body
226 (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
228 allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
229 ) `thenFC` \ heap_offset ->
232 returnFC (binder, heapIdInfo binder heap_offset lf_info)
235 %************************************************************************
237 \subsection[code-for-closures]{The code for closures}
239 %************************************************************************
242 closureCodeBody :: StgBinderInfo
243 -> ClosureInfo -- Lots of information about this closure
244 -> CostCentreStack -- Optional cost centre attached to closure
250 There are two main cases for the code for closures. If there are {\em
251 no arguments}, then the closure is a thunk, and not in normal form.
252 So it should set up an update frame (if it is shared). Also, it has
253 no argument satisfaction check, so fast and slow entry-point labels
257 closureCodeBody binder_info closure_info cc [] body
258 = -- thunks cannot have a primitive type!
259 getAbsC body_code `thenFC` \ body_absC ->
260 moduleName `thenFC` \ mod_name ->
262 absC (CClosureInfoAndCode closure_info body_absC Nothing
265 cl_descr mod_name = closureDescription mod_name (closureName closure_info)
267 body_label = entryLabelFromCI closure_info
269 is_box = case body of { StgApp fun [] -> True; _ -> False }
271 body_code = profCtrC SLIT("TICK_ENT_THK") [] `thenC`
272 thunkWrapper closure_info body_label (
273 -- We only enter cc after setting up update so that cc
274 -- of enclosing scope will be recorded in update frame
275 -- CAF/DICT functions will be subsumed by this enclosing cc
276 enterCostCentreCode closure_info cc IsThunk is_box `thenC`
280 If there is {\em at least one argument}, then this closure is in
281 normal form, so there is no need to set up an update frame. On the
282 other hand, we do have to check that there are enough args, and
283 perform an update if not!
285 The Macros for GrAnSim are produced at the beginning of the
286 argSatisfactionCheck (by calling fetchAndReschedule). There info if
287 Node points to closure is available. -- HWL
290 closureCodeBody binder_info closure_info cc all_args body
291 = getEntryConvention name lf_info
292 (map idPrimRep all_args) `thenFC` \ entry_conv ->
294 -- get the current virtual Sp (it might not be zero, eg. if we're
295 -- compiling a let-no-escape).
296 getVirtSp `thenFC` \vSp ->
299 -- Figure out what is needed and what isn't
301 -- SDM: need everything for now in case the heap/stack check refers
303 slow_code_needed = True
304 --slowFunEntryCodeRequired name binder_info entry_conv
305 info_table_needed = True
306 --funInfoTableRequired name binder_info lf_info
308 -- Arg mapping for standard (slow) entry point; all args on stack,
310 (sp_all_args, arg_offsets, _)
311 = mkTaggedVirtStkOffsets vSp idPrimRep all_args
313 -- Arg mapping for the fast entry point; as many args as poss in
314 -- registers; the rest on the stack
315 -- arg_regs are the registers used for arg passing
316 -- stk_args are the args which are passed on the stack
318 -- Args passed on the stack are tagged, but the tags may not
319 -- actually be present (just gaps) if the function is called
320 -- by jumping directly to the fast entry point.
322 arg_regs = case entry_conv of
323 DirectEntry lbl arity regs -> regs
324 other -> trace ("*** closureCodeBody:arg_regs " ++ (pprHWL entry_conv) ++ "(HWL ignored; no args passed in regs)") []
326 pprHWL :: EntryConvention -> String
327 pprHWL (ViaNode) = "ViaNode"
328 pprHWL (StdEntry cl) = "StdEntry"
329 pprHWL (DirectEntry cl i l) = "DirectEntry"
331 num_arg_regs = length arg_regs
333 (reg_args, stk_args) = splitAt num_arg_regs all_args
335 (sp_stk_args, stk_offsets, stk_tags)
336 = mkTaggedVirtStkOffsets vSp idPrimRep stk_args
338 -- HWL; Note: empty list of live regs in slow entry code
339 -- Old version (reschedule combined with heap check);
340 -- see argSatisfactionCheck for new version
341 --slow_entry_code = forceHeapCheck [node] True slow_entry_code'
342 -- where node = UnusedReg PtrRep 1
343 --slow_entry_code = forceHeapCheck [] True slow_entry_code'
346 = profCtrC SLIT("TICK_ENT_FUN_STD") [
347 CLbl ticky_ctr_label DataPtrRep
350 -- Bind args, and record expected position of stk ptrs
351 mapCs bindNewToStack arg_offsets `thenC`
352 setRealAndVirtualSp sp_all_args `thenC`
354 argSatisfactionCheck closure_info arg_regs `thenC`
356 -- OK, so there are enough args. Now we need to stuff as
357 -- many of them in registers as the fast-entry code
358 -- expects. Note that the zipWith will give up when it hits
359 -- the end of arg_regs.
361 mapFCs getCAddrMode all_args `thenFC` \ stk_amodes ->
362 absC (mkAbstractCs (zipWith assign_to_reg arg_regs stk_amodes))
365 -- Now adjust real stack pointers (no need to adjust Hp,
366 -- but call this function for convenience).
367 adjustSpAndHp sp_stk_args `thenC`
369 absC (CFallThrough (CLbl fast_label CodePtrRep))
371 assign_to_reg reg_id amode = CAssign (CReg reg_id) amode
374 -- Old version (reschedule combined with heap check);
375 -- see argSatisfactionCheck for new version
376 -- fast_entry_code = forceHeapCheck [] True fast_entry_code'
379 = moduleName `thenFC` \ mod_name ->
380 profCtrC SLIT("TICK_CTR") [
381 CLbl ticky_ctr_label DataPtrRep,
382 mkCString (_PK_ (ppr_for_ticky_name mod_name name)),
383 mkIntCLit stg_arity, -- total # of args
384 mkIntCLit sp_stk_args, -- # passed on stk
385 mkCString (_PK_ (map (showTypeCategory . idType) all_args))
388 profCtrC SLIT("TICK_ENT_FUN_DIRECT") [
389 CLbl ticky_ctr_label DataPtrRep
392 -- Nuked for now; see comment at end of file
393 -- CString (_PK_ (show_wrapper_name wrapper_maybe)),
394 -- CString (_PK_ (show_wrapper_arg_kinds wrapper_maybe))
397 -- Bind args to regs/stack as appropriate, and
398 -- record expected position of sps.
399 bindArgsToRegs reg_args arg_regs `thenC`
400 mapCs bindNewToStack stk_offsets `thenC`
401 setRealAndVirtualSp sp_stk_args `thenC`
403 -- free up the stack slots containing tags
404 freeStackSlots (map fst stk_tags) `thenC`
406 -- Enter the closures cc, if required
407 enterCostCentreCode closure_info cc IsFunction False `thenC`
410 funWrapper closure_info arg_regs stk_tags info_label (cgExpr body)
413 setTickyCtrLabel ticky_ctr_label (
415 -- Make a labelled code-block for the slow and fast entry code
416 forkAbsC (if slow_code_needed then slow_entry_code else absC AbsCNop)
417 `thenFC` \ slow_abs_c ->
418 forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
419 moduleName `thenFC` \ mod_name ->
421 -- Now either construct the info table, or put the fast code in alone
422 -- (We never have slow code without an info table)
423 -- XXX probably need the info table and slow entry code in case of
424 -- a heap check failure.
426 if info_table_needed then
427 CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
430 CCodeBlock fast_label fast_abs_c
434 ticky_ctr_label = mkRednCountsLabel name
436 stg_arity = length all_args
437 lf_info = closureLFInfo closure_info
439 cl_descr mod_name = closureDescription mod_name name
441 -- Manufacture labels
442 name = closureName closure_info
443 fast_label = mkFastEntryLabel name stg_arity
444 info_label = mkInfoTableLabel name
447 -- When printing the name of a thing in a ticky file, we want to
448 -- give the module name even for *local* things. We print
449 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
450 ppr_for_ticky_name mod_name name
451 | isLocalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
452 | otherwise = showSDocDebug (ppr name)
455 For lexically scoped profiling we have to load the cost centre from
456 the closure entered, if the costs are not supposed to be inherited.
457 This is done immediately on entering the fast entry point.
459 Load current cost centre from closure, if not inherited.
460 Node is guaranteed to point to it, if profiling and not inherited.
463 data IsThunk = IsThunk | IsFunction -- Bool-like, local
469 :: ClosureInfo -> CostCentreStack
471 -> Bool -- is_box: this closure is a special box introduced by SCCfinal
474 enterCostCentreCode closure_info ccs is_thunk is_box
475 = if not opt_SccProfilingOn then
478 ASSERT(not (noCCSAttached ccs))
480 if isSubsumedCCS ccs then
481 ASSERT(isToplevClosure closure_info)
482 ASSERT(is_thunk == IsFunction)
483 costCentresC SLIT("ENTER_CCS_FSUB") []
485 else if isCurrentCCS ccs then
486 if re_entrant && not is_box
487 then costCentresC SLIT("ENTER_CCS_FCL") [CReg node]
488 else costCentresC SLIT("ENTER_CCS_TCL") [CReg node]
490 else if isCafCCS ccs then
491 ASSERT(isToplevClosure closure_info)
492 ASSERT(is_thunk == IsThunk)
493 -- might be a PAP, in which case we want to subsume costs
495 then costCentresC SLIT("ENTER_CCS_FSUB") []
496 else costCentresC SLIT("ENTER_CCS_CAF") c_ccs
498 else panic "enterCostCentreCode"
501 c_ccs = [mkCCostCentreStack ccs]
502 re_entrant = closureReEntrant closure_info
505 %************************************************************************
507 \subsubsection[pre-closure-code-stuff]{Pre-closure-code code}
509 %************************************************************************
511 The argument-satisfaction check code is placed after binding
512 the arguments to their stack locations. Hence, the virtual stack
513 pointer is pointing after all the args, and virtual offset 1 means
514 the base of frame and hence most distant arg. Hence
515 virtual offset 0 is just beyond the most distant argument; the
516 relative offset of this word tells how many words of arguments
520 argSatisfactionCheck :: ClosureInfo -> [MagicId] {-GRAN-} -> Code
522 argSatisfactionCheck closure_info arg_regs
524 = nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
527 -- emit_gran_macros = opt_GranMacros
531 -- absC (CMacroStmt GRAN_FETCH []) `thenC`
532 -- forceHeapCheck [] node_points (absC AbsCNop) `thenC`
534 -- then if node_points
535 -- then fetchAndReschedule arg_regs node_points
536 -- else yield arg_regs node_points
537 -- else absC AbsCNop) `thenC`
539 getSpRelOffset 0 `thenFC` \ (SpRel sp) ->
542 rel_arg = mkIntCLit off
546 absC (CMacroStmt ARGS_CHK [rel_arg]) -- node already points
548 absC (CMacroStmt ARGS_CHK_LOAD_NODE [rel_arg, set_Node_to_this])
550 -- We must tell the arg-satis macro whether Node is pointing to
551 -- the closure or not. If it isn't so pointing, then we give to
552 -- the macro the (static) address of the closure.
554 set_Node_to_this = CLbl (closureLabelFromCI closure_info) PtrRep
557 %************************************************************************
559 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
561 %************************************************************************
564 thunkWrapper:: ClosureInfo -> CLabel -> Code -> Code
565 thunkWrapper closure_info lbl thunk_code
566 = -- Stack and heap overflow checks
567 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
569 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
570 -- (we prefer fetchAndReschedule-style context switches to yield ones)
573 then fetchAndReschedule [] node_points
574 else yield [] node_points
575 else absC AbsCNop) `thenC`
577 -- stack and/or heap checks
578 thunkChecks lbl node_points (
580 -- Overwrite with black hole if necessary
581 blackHoleIt closure_info node_points `thenC`
583 setupUpdate closure_info ( -- setupUpdate *encloses* the rest
585 -- Finally, do the business
589 funWrapper :: ClosureInfo -- Closure whose code body this is
590 -> [MagicId] -- List of argument registers (if any)
591 -> [(VirtualSpOffset,Int)] -- tagged stack slots
592 -> CLabel -- info table for heap check ret.
593 -> Code -- Body of function being compiled
595 funWrapper closure_info arg_regs stk_tags info_label fun_body
596 = -- Stack overflow check
597 nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
600 then yield arg_regs node_points
601 else absC AbsCNop) `thenC`
603 -- heap and/or stack checks
604 fastEntryChecks arg_regs stk_tags info_label node_points (
606 -- Finally, do the business
612 %************************************************************************
614 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
616 %************************************************************************
620 blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
622 blackHoleIt closure_info node_points
623 = if blackHoleOnEntry closure_info && node_points
626 info_label = infoTableLabelFromCI closure_info
627 args = [ CLbl info_label DataPtrRep ]
629 absC (if closureSingleEntry(closure_info) then
630 CMacroStmt UPD_BH_SINGLE_ENTRY args
632 CMacroStmt UPD_BH_UPDATABLE args)
638 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
639 -- Nota Bene: this function does not change Node (even if it's a CAF),
640 -- so that the cost centre in the original closure can still be
641 -- extracted by a subsequent ENTER_CC_TCL
643 -- I've tidied up the code for this function, but it should still do the same as
644 -- it did before (modulo ticky stuff). KSW 1999-04.
645 setupUpdate closure_info code
646 = if closureReEntrant closure_info
650 case (closureUpdReqd closure_info, isStaticClosure closure_info) of
651 (False,False) -> profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
653 (False,True ) -> (if opt_DoTickyProfiling
655 -- blackhole the SE CAF
656 link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
659 profCtrC SLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
660 profCtrC SLIT("TICK_UPDF_OMITTED") [] `thenC`
662 (True ,False) -> pushUpdateFrame (CReg node) code
663 (True ,True ) -> -- blackhole the (updatable) CAF:
664 link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
665 profCtrC SLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
666 pushUpdateFrame update_closure code
668 cl_name :: FAST_STRING
669 cl_name = (occNameFS . nameOccName . closureName) closure_info
671 link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
672 -> FCode CAddrMode -- Returns amode for closure to be updated
674 = -- To update a CAF we must allocate a black hole, link the CAF onto the
675 -- CAF list, then update the CAF to point to the fresh black hole.
676 -- This function returns the address of the black hole, so it can be
677 -- updated with the new value when available.
679 -- Alloc black hole specifying CC_HDR(Node) as the cost centre
681 use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
684 allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
685 getHpRelOffset heap_offset `thenFC` \ hp_rel ->
686 let amode = CAddr hp_rel
688 absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
692 %************************************************************************
694 \subsection[CgClosure-Description]{Profiling Closure Description.}
696 %************************************************************************
698 For "global" data constructors the description is simply occurrence
699 name of the data constructor itself (see \ref{CgConTbls-info-tables}).
701 Otherwise it is determind by @closureDescription@ from the let
705 closureDescription :: Module -- Module
706 -> Name -- Id of closure binding
709 -- Not called for StgRhsCon which have global info tables built in
710 -- CgConTbls.lhs with a description generated from the data constructor
712 closureDescription mod_name name
722 chooseDynCostCentres ccs args fvs body
724 use_cc -- cost-centre we record in the object
725 = if currentOrSubsumedCCS ccs
726 then CReg CurCostCentre
727 else mkCCostCentreStack ccs
729 blame_cc -- cost-centre on whom we blame the allocation
730 = case (args, fvs, body) of
731 ([], _, StgApp fun [{-no args-}])
732 -> mkCCostCentreStack overheadCCS
735 -- if it's an utterly trivial RHS, then it must be
736 -- one introduced by boxHigherOrderArgs for profiling,
737 -- so we charge it to "OVERHEAD".
739 -- This looks like a HACK to me --SDM