2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[CgClosure]{Code generation for closures}
7 This module provides the support code for @StgToAbstractC@ to deal
8 with {\em closures} on the RHSs of let(rec)s. See also
9 @CgCon@, which deals with constructors.
12 module CgClosure ( cgTopRhsClosure,
18 #include "HsVersions.h"
20 import {-# SOURCE #-} CgExpr ( cgExpr )
54 %********************************************************
56 \subsection[closures-no-free-vars]{Top-level closures}
58 %********************************************************
60 For closures bound at top level, allocate in static space.
61 They should have no free variables.
65 -> CostCentreStack -- Optional cost centre annotation
70 -> FCode (Id, CgIdInfo)
72 cgTopRhsClosure id ccs binder_info upd_flag args body = do
73 { -- LAY OUT THE OBJECT
75 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
76 ; srt_info <- getSRTInfo
77 ; mod_name <- getModuleName
78 ; let descr = closureDescription mod_name name
79 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
80 closure_label = mkLocalClosureLabel name $ idCafInfo id
81 cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
82 closure_rep = mkStaticClosureFields closure_info ccs True []
84 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
85 ; emitDataLits closure_label closure_rep
86 ; forkClosureBody (closureCodeBody binder_info closure_info
89 ; returnFC (id, cg_id_info) }
92 %********************************************************
94 \subsection[non-top-level-closures]{Non top-level closures}
96 %********************************************************
98 For closures with free vars, allocate in heap.
103 -> CostCentreStack -- Optional cost centre annotation
109 -> [StgArg] -- payload
110 -> FCode (Id, CgIdInfo)
112 cgStdRhsClosure bndr cc _bndr_info _fvs args body lf_info payload
113 = do -- AHA! A STANDARD-FORM THUNK
114 { -- LAY OUT THE OBJECT
115 amodes <- getArgAmodes payload
116 ; mod_name <- getModuleName
117 ; let (tot_wds, ptr_wds, amodes_w_offsets)
118 = mkVirtHeapOffsets (isLFThunk lf_info) amodes
120 descr = closureDescription mod_name (idName bndr)
121 closure_info = mkClosureInfo False -- Not static
122 bndr lf_info tot_wds ptr_wds
123 NoC_SRT -- No SRT for a std-form closure
126 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
129 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
132 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
135 Here's the general case.
139 -> CostCentreStack -- Optional cost centre annotation
145 -> FCode (Id, CgIdInfo)
147 cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
148 { -- LAY OUT THE OBJECT
149 -- If the binder is itself a free variable, then don't store
150 -- it in the closure. Instead, just bind it to Node on entry.
151 -- NB we can be sure that Node will point to it, because we
152 -- havn't told mkClosureLFInfo about this; so if the binder
153 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
154 -- stored in the closure itself, so it will make sure that
155 -- Node points to it...
158 bndr_is_a_fv = bndr `elem` fvs
159 reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
162 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
163 ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
164 ; srt_info <- getSRTInfo
165 ; mod_name <- getModuleName
166 ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
167 (tot_wds, ptr_wds, bind_details)
168 = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
170 add_rep info = (cgIdInfoArgRep info, info)
172 descr = closureDescription mod_name name
173 closure_info = mkClosureInfo False -- Not static
174 bndr lf_info tot_wds ptr_wds
177 -- BUILD ITS INFO TABLE AND CODE
178 ; forkClosureBody (do
181 -- A function closure pointer may be tagged, so we
182 -- must take it into account when accessing the free variables.
183 mbtag = tagForArity (length args)
184 bind_fv (info, offset)
186 = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
188 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
189 ; mapCs bind_fv bind_details
191 -- Bind the binder itself, if it is a free var
192 ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
195 ; closureCodeBody bndr_info closure_info cc args body })
199 to_amode (info, offset) = do { amode <- idInfoToAmode info
200 ; return (amode, offset) }
201 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
202 ; amodes_w_offsets <- mapFCs to_amode bind_details
203 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
206 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
209 mkClosureLFInfo :: Id -- The binder
210 -> TopLevelFlag -- True of top level
212 -> UpdateFlag -- Update flag
214 -> FCode LambdaFormInfo
215 mkClosureLFInfo bndr top fvs upd_flag args
216 | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
217 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
218 ; return (mkLFReEntrant top fvs args arg_descr) }
222 %************************************************************************
224 \subsection[code-for-closures]{The code for closures}
226 %************************************************************************
229 closureCodeBody :: StgBinderInfo
230 -> ClosureInfo -- Lots of information about this closure
231 -> CostCentreStack -- Optional cost centre attached to closure
237 There are two main cases for the code for closures. If there are {\em
238 no arguments}, then the closure is a thunk, and not in normal form.
239 So it should set up an update frame (if it is shared).
240 NB: Thunks cannot have a primitive type!
243 closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do
244 { body_absC <- getCgStmts $ do
245 { tickyEnterThunk cl_info
246 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
247 ; thunkWrapper cl_info $ do
248 -- We only enter cc after setting up update so
249 -- that cc of enclosing scope will be recorded
250 -- in update frame CAF/DICT functions will be
251 -- subsumed by this enclosing cc
252 { enterCostCentre cl_info cc body
256 ; emitClosureCodeAndInfoTable cl_info [] body_absC }
259 If there is /at least one argument/, then this closure is in
260 normal form, so there is no need to set up an update frame.
262 The Macros for GrAnSim are produced at the beginning of the
263 argSatisfactionCheck (by calling fetchAndReschedule). There info if
264 Node points to closure is available. -- HWL
267 closureCodeBody _binder_info cl_info cc args body
268 = ASSERT( length args > 0 )
269 do { -- Get the current virtual Sp (it might not be zero,
270 -- eg. if we're compiling a let-no-escape).
272 ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
273 (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
275 -- Allocate the global ticky counter
276 ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
277 ; emitTickyCounter cl_info args sp_top
279 -- ...and establish the ticky-counter
280 -- label for this block
281 ; setTickyCtrLabel ticky_ctr_lbl $ do
283 -- Emit the slow-entry code
284 { reg_save_code <- mkSlowEntryCode cl_info reg_args
286 -- Emit the main entry code
288 mkFunEntryCode cl_info cc reg_args stk_args
289 sp_top reg_save_code body
290 ; emitClosureCodeAndInfoTable cl_info [] blks
295 mkFunEntryCode :: ClosureInfo
297 -> [(Id,GlobalReg)] -- Args in regs
298 -> [(Id,VirtualSpOffset)] -- Args on stack
299 -> VirtualSpOffset -- Last allocated word on stack
300 -> CmmStmts -- Register-save code in case of GC
303 -- The main entry code for the closure
304 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
305 { -- Bind args to regs/stack as appropriate,
306 -- and record expected position of sps
307 ; bindArgsToRegs reg_args
308 ; bindArgsToStack stk_args
309 ; setRealAndVirtualSp sp_top
311 -- Enter the cost-centre, if required
312 -- ToDo: It's not clear why this is outside the funWrapper,
313 -- but the tickyEnterFun is inside. Perhaps we can put
315 ; enterCostCentre cl_info cc body
318 ; funWrapper cl_info reg_args reg_save_code $ do
319 { tickyEnterFun cl_info
324 The "slow entry" code for a function. This entry point takes its
325 arguments on the stack. It loads the arguments into registers
326 according to the calling convention, and jumps to the function's
327 normal entry point. The function's closure is assumed to be in
330 The slow entry point is used in two places:
332 (a) unknown calls: eg. stg_PAP_entry
333 (b) returning from a heap-check failure
336 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
337 -- If this function doesn't have a specialised ArgDescr, we need
338 -- to generate the function's arg bitmap, slow-entry code, and
339 -- register-save code for the heap-check failure
340 -- Here, we emit the slow-entry code, and
341 -- return the register-save assignments
342 mkSlowEntryCode cl_info reg_args
343 | Just (_, ArgGen _) <- closureFunInfo cl_info
344 = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
345 ; return save_stmts }
346 | otherwise = return noStmts
348 name = closureName cl_info
349 has_caf_refs = clHasCafRefs cl_info
350 slow_lbl = mkSlowEntryLabel name has_caf_refs
352 load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
353 save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
355 reps_w_regs :: [(CgRep,GlobalReg)]
356 reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
357 (final_stk_offset, stk_offsets)
358 = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
361 load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
362 mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
363 (CmmLoad (cmmRegOffW spReg offset)
366 save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
367 mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg )
368 CmmStore (cmmRegOffW spReg offset)
369 (CmmReg (CmmGlobal reg))
371 stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
372 stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
373 jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) []
377 %************************************************************************
379 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
381 %************************************************************************
384 thunkWrapper:: ClosureInfo -> Code -> Code
385 thunkWrapper closure_info thunk_code = do
386 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
388 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
389 -- (we prefer fetchAndReschedule-style context switches to yield ones)
391 then granFetchAndReschedule [] node_points
392 else granYield [] node_points
394 -- Stack and/or heap checks
395 ; thunkEntryChecks closure_info $ do
397 dflags <- getDynFlags
398 -- Overwrite with black hole if necessary
399 ; whenC (blackHoleOnEntry dflags closure_info && node_points)
400 (blackHoleIt closure_info)
401 ; setupUpdate closure_info thunk_code }
402 -- setupUpdate *encloses* the thunk_code
405 funWrapper :: ClosureInfo -- Closure whose code body this is
406 -> [(Id,GlobalReg)] -- List of argument registers (if any)
407 -> CmmStmts -- reg saves for the heap check failure
408 -> Code -- Body of function being compiled
410 funWrapper closure_info arg_regs reg_save_code fun_body = do
411 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
414 -- Debugging: check that R1 has the correct tag
415 ; let tag = funTag closure_info
416 ; whenC (tag /= 0 && node_points) $ do
418 stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
419 CmmLit (mkIntCLit tag)]) l)
420 stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
424 -- Enter for Ldv profiling
425 ; whenC node_points (ldvEnterClosure closure_info)
427 -- GranSim yeild poin
428 ; granYield arg_regs node_points
430 -- Heap and/or stack checks wrap the function body
431 ; funEntryChecks closure_info reg_save_code
437 %************************************************************************
439 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
441 %************************************************************************
445 blackHoleIt :: ClosureInfo -> Code
446 -- Only called for closures with no args
447 -- Node points to the closure
448 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
450 emitBlackHoleCode :: Bool -> Code
451 emitBlackHoleCode is_single_entry = do
453 dflags <- getDynFlags
455 -- If we wanted to do eager blackholing with slop filling,
456 -- we'd need to do it at the *end* of a basic block, otherwise
457 -- we overwrite the free variables in the thunk that we still
458 -- need. We have a patch for this from Andy Cheadle, but not
459 -- incorporated yet. --SDM [6/2004]
461 -- Profiling needs slop filling (to support LDV profiling), so
462 -- currently eager blackholing doesn't work with profiling.
464 -- Previously, eager blackholing was enabled when ticky-ticky
465 -- was on. But it didn't work, and it wasn't strictly necessary
466 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
467 -- is unconditionally disabled. -- krc 1/2007
469 let eager_blackholing = not opt_SccProfilingOn
470 && dopt Opt_EagerBlackHoling dflags
474 tickyBlackHole (not is_single_entry)
475 let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo)
477 CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
478 (CmmReg (CmmGlobal CurrentTSO)),
479 CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmUnsafe CmmMayReturn,
480 CmmStore (CmmReg nodeReg) bh_info
487 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
488 -- Nota Bene: this function does not change Node (even if it's a CAF),
489 -- so that the cost centre in the original closure can still be
490 -- extracted by a subsequent enterCostCentre
491 setupUpdate closure_info code
492 | closureReEntrant closure_info
495 | not (isStaticClosure closure_info)
497 if not (closureUpdReqd closure_info)
498 then do tickyUpdateFrameOmitted; code
501 dflags <- getDynFlags
502 if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
503 then pushBHUpdateFrame (CmmReg nodeReg) code
504 else pushUpdateFrame (CmmReg nodeReg) code
506 | otherwise -- A static closure
507 = do { tickyUpdateBhCaf closure_info
509 ; if closureUpdReqd closure_info
510 then do -- Blackhole the (updatable) CAF:
511 { upd_closure <- link_caf closure_info True
512 ; pushBHUpdateFrame upd_closure code }
514 { -- krc: removed some ticky-related code here.
515 ; tickyUpdateFrameOmitted
520 -----------------------------------------------------------------------------
523 -- When a CAF is first entered, it creates a black hole in the heap,
524 -- and updates itself with an indirection to this new black hole.
526 -- We update the CAF with an indirection to a newly-allocated black
527 -- hole in the heap. We also set the blocking queue on the newly
528 -- allocated black hole to be empty.
530 -- Why do we make a black hole in the heap when we enter a CAF?
532 -- - for a generational garbage collector, which needs a fast
533 -- test for whether an updatee is in an old generation or not
535 -- - for the parallel system, which can implement updates more
536 -- easily if the updatee is always in the heap. (allegedly).
538 -- When debugging, we maintain a separate CAF list so we can tell when
539 -- a CAF has been garbage collected.
541 -- newCAF must be called before the itbl ptr is overwritten, since
542 -- newCAF records the old itbl ptr in order to do CAF reverting
543 -- (which Hugs needs to do in order that combined mode works right.)
546 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
547 -- into the "newCAF" RTS procedure, which we call anyway, including
548 -- the allocation of the black-hole indirection closure.
549 -- That way, code size would fall, the CAF-handling code would
550 -- be closer together, and the compiler wouldn't need to know
551 -- about off_indirectee etc.
553 link_caf :: ClosureInfo
554 -> Bool -- True <=> updatable, False <=> single-entry
555 -> FCode CmmExpr -- Returns amode for closure to be updated
556 -- To update a CAF we must allocate a black hole, link the CAF onto the
557 -- CAF list, then update the CAF to point to the fresh black hole.
558 -- This function returns the address of the black hole, so it can be
559 -- updated with the new value when available. The reason for all of this
560 -- is that we only want to update dynamic heap objects, not static ones,
561 -- so that generational GC is easier.
562 link_caf cl_info _is_upd = do
563 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
564 ; let use_cc = costCentreFrom (CmmReg nodeReg)
566 tso = CmmReg (CmmGlobal CurrentTSO)
567 ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
568 ; hp_rel <- getHpRelOffset hp_offset
570 -- Call the RTS function newCAF to add the CAF to the CafList
571 -- so that the garbage collector can find them
572 -- This must be done *before* the info table pointer is overwritten,
573 -- because the old info table ptr is needed for reversion
574 ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
575 [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
576 CmmHinted (CmmReg nodeReg) AddrHint ]
578 -- node is live, so save it.
580 -- Overwrite the closure with a (static) indirection
581 -- to the newly-allocated black hole
582 ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
583 , CmmStore (CmmReg nodeReg) ind_static_info ]
587 bh_cl_info :: ClosureInfo
588 bh_cl_info = cafBlackHoleClosureInfo cl_info
590 ind_static_info :: CmmExpr
591 ind_static_info = mkLblExpr mkIndStaticInfoLabel
593 off_indirectee :: WordOff
594 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
598 %************************************************************************
600 \subsection[CgClosure-Description]{Profiling Closure Description.}
602 %************************************************************************
604 For "global" data constructors the description is simply occurrence
605 name of the data constructor itself. Otherwise it is determined by
606 @closureDescription@ from the let binding information.
609 closureDescription :: Module -- Module
610 -> Name -- Id of closure binding
612 -- Not called for StgRhsCon which have global info tables built in
613 -- CgConTbls.lhs with a description generated from the data constructor
614 closureDescription mod_name name
615 = showSDocDumpOneLine (char '<' <>
616 (if isExternalName name
617 then ppr name -- ppr will include the module name prefix
618 else pprModule mod_name <> char '.' <> ppr name) <>
620 -- showSDocDumpOneLine, because we want to see the unique on the Name.