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 )
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 upd_flag args body = do
72 { -- LAY OUT THE OBJECT
74 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
75 ; srt_info <- getSRTInfo name srt
76 ; mod_name <- getModuleName
77 ; let descr = closureDescription mod_name name
78 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
79 closure_label = mkLocalClosureLabel name
80 cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
81 closure_rep = mkStaticClosureFields closure_info ccs True []
83 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
84 ; emitDataLits closure_label closure_rep
85 ; forkClosureBody (closureCodeBody binder_info closure_info
88 ; returnFC (id, cg_id_info) }
91 %********************************************************
93 \subsection[non-top-level-closures]{Non top-level closures}
95 %********************************************************
97 For closures with free vars, allocate in heap.
102 -> CostCentreStack -- Optional cost centre annotation
108 -> [StgArg] -- payload
109 -> FCode (Id, CgIdInfo)
111 cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
112 = do -- AHA! A STANDARD-FORM THUNK
113 { -- LAY OUT THE OBJECT
114 amodes <- getArgAmodes payload
115 ; mod_name <- getModuleName
116 ; let (tot_wds, ptr_wds, amodes_w_offsets)
117 = mkVirtHeapOffsets (isLFThunk lf_info) amodes
119 descr = closureDescription mod_name (idName bndr)
120 closure_info = mkClosureInfo False -- Not static
121 bndr lf_info tot_wds ptr_wds
122 NoC_SRT -- No SRT for a std-form closure
125 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
128 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
131 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
134 Here's the general case.
138 -> CostCentreStack -- Optional cost centre annotation
145 -> FCode (Id, CgIdInfo)
147 cgRhsClosure bndr cc bndr_info srt 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 is_elem = isIn "cgRhsClosure"
159 bndr_is_a_fv = bndr `is_elem` fvs
160 reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
163 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
164 ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
165 ; srt_info <- getSRTInfo name srt
166 ; mod_name <- getModuleName
167 ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
168 (tot_wds, ptr_wds, bind_details)
169 = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
171 add_rep info = (cgIdInfoArgRep info, info)
173 descr = closureDescription mod_name name
174 closure_info = mkClosureInfo False -- Not static
175 bndr lf_info tot_wds ptr_wds
178 -- BUILD ITS INFO TABLE AND CODE
179 ; forkClosureBody (do
181 let bind_fv (info, offset)
182 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
183 ; mapCs bind_fv bind_details
185 -- Bind the binder itself, if it is a free var
186 ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
189 ; closureCodeBody bndr_info closure_info cc args body })
193 to_amode (info, offset) = do { amode <- idInfoToAmode info
194 ; return (amode, offset) }
195 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
196 ; amodes_w_offsets <- mapFCs to_amode bind_details
197 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
200 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
203 mkClosureLFInfo :: Id -- The binder
204 -> TopLevelFlag -- True of top level
206 -> UpdateFlag -- Update flag
208 -> FCode LambdaFormInfo
209 mkClosureLFInfo bndr top fvs upd_flag args
210 | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
211 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
212 ; return (mkLFReEntrant top fvs args arg_descr) }
216 %************************************************************************
218 \subsection[code-for-closures]{The code for closures}
220 %************************************************************************
223 closureCodeBody :: StgBinderInfo
224 -> ClosureInfo -- Lots of information about this closure
225 -> CostCentreStack -- Optional cost centre attached to closure
231 There are two main cases for the code for closures. If there are {\em
232 no arguments}, then the closure is a thunk, and not in normal form.
233 So it should set up an update frame (if it is shared).
234 NB: Thunks cannot have a primitive type!
237 closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
238 { body_absC <- getCgStmts $ do
239 { tickyEnterThunk cl_info
240 ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
241 ; thunkWrapper cl_info $ do
242 -- We only enter cc after setting up update so
243 -- that cc of enclosing scope will be recorded
244 -- in update frame CAF/DICT functions will be
245 -- subsumed by this enclosing cc
246 { enterCostCentre cl_info cc body
250 ; emitClosureCodeAndInfoTable cl_info [] body_absC }
253 If there is /at least one argument/, then this closure is in
254 normal form, so there is no need to set up an update frame.
256 The Macros for GrAnSim are produced at the beginning of the
257 argSatisfactionCheck (by calling fetchAndReschedule). There info if
258 Node points to closure is available. -- HWL
261 closureCodeBody binder_info cl_info cc args body
262 = ASSERT( length args > 0 )
263 do { -- Get the current virtual Sp (it might not be zero,
264 -- eg. if we're compiling a let-no-escape).
266 ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
267 (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
269 -- Allocate the global ticky counter
270 ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
271 ; emitTickyCounter cl_info args sp_top
273 -- ...and establish the ticky-counter
274 -- label for this block
275 ; setTickyCtrLabel ticky_ctr_lbl $ do
277 -- Emit the slow-entry code
278 { reg_save_code <- mkSlowEntryCode cl_info reg_args
280 -- Emit the main entry code
282 mkFunEntryCode cl_info cc reg_args stk_args
283 sp_top reg_save_code body
284 ; emitClosureCodeAndInfoTable cl_info [] blks
289 mkFunEntryCode :: ClosureInfo
291 -> [(Id,GlobalReg)] -- Args in regs
292 -> [(Id,VirtualSpOffset)] -- Args on stack
293 -> VirtualSpOffset -- Last allocated word on stack
294 -> CmmStmts -- Register-save code in case of GC
297 -- The main entry code for the closure
298 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
299 { -- Bind args to regs/stack as appropriate,
300 -- and record expected position of sps
301 ; bindArgsToRegs reg_args
302 ; bindArgsToStack stk_args
303 ; setRealAndVirtualSp sp_top
305 -- Enter the cost-centre, if required
306 -- ToDo: It's not clear why this is outside the funWrapper,
307 -- but the tickyEnterFun is inside. Perhaps we can put
309 ; enterCostCentre cl_info cc body
312 ; funWrapper cl_info reg_args reg_save_code $ do
313 { tickyEnterFun cl_info
318 The "slow entry" code for a function. This entry point takes its
319 arguments on the stack. It loads the arguments into registers
320 according to the calling convention, and jumps to the function's
321 normal entry point. The function's closure is assumed to be in
324 The slow entry point is used in two places:
326 (a) unknown calls: eg. stg_PAP_entry
327 (b) returning from a heap-check failure
330 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
331 -- If this function doesn't have a specialised ArgDescr, we need
332 -- to generate the function's arg bitmap, slow-entry code, and
333 -- register-save code for the heap-check failure
334 -- Here, we emit the slow-entry code, and
335 -- return the register-save assignments
336 mkSlowEntryCode cl_info reg_args
337 | Just (_, ArgGen _) <- closureFunInfo cl_info
338 = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
339 ; return save_stmts }
340 | otherwise = return noStmts
342 name = closureName cl_info
343 slow_lbl = mkSlowEntryLabel name
345 load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
346 save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
348 reps_w_regs :: [(CgRep,GlobalReg)]
349 reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
350 (final_stk_offset, stk_offsets)
351 = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
354 load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
355 mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
356 (CmmLoad (cmmRegOffW spReg offset)
359 save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
360 mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
361 CmmStore (cmmRegOffW spReg offset)
362 (CmmReg (CmmGlobal reg))
364 stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
365 stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
366 jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
370 %************************************************************************
372 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
374 %************************************************************************
377 thunkWrapper:: ClosureInfo -> Code -> Code
378 thunkWrapper closure_info thunk_code = do
379 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
381 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
382 -- (we prefer fetchAndReschedule-style context switches to yield ones)
384 then granFetchAndReschedule [] node_points
385 else granYield [] node_points
387 -- Stack and/or heap checks
388 ; thunkEntryChecks closure_info $ do
389 { -- Overwrite with black hole if necessary
390 whenC (blackHoleOnEntry closure_info && node_points)
391 (blackHoleIt closure_info)
392 ; setupUpdate closure_info thunk_code }
393 -- setupUpdate *encloses* the thunk_code
396 funWrapper :: ClosureInfo -- Closure whose code body this is
397 -> [(Id,GlobalReg)] -- List of argument registers (if any)
398 -> CmmStmts -- reg saves for the heap check failure
399 -> Code -- Body of function being compiled
401 funWrapper closure_info arg_regs reg_save_code fun_body = do
402 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
404 -- Enter for Ldv profiling
405 ; whenC node_points (ldvEnter (CmmReg nodeReg))
407 -- GranSim yeild poin
408 ; granYield arg_regs node_points
410 -- Heap and/or stack checks wrap the function body
411 ; funEntryChecks closure_info reg_save_code
417 %************************************************************************
419 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
421 %************************************************************************
425 blackHoleIt :: ClosureInfo -> Code
426 -- Only called for closures with no args
427 -- Node points to the closure
428 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
430 emitBlackHoleCode :: Bool -> Code
431 emitBlackHoleCode is_single_entry
432 | eager_blackholing = do
433 tickyBlackHole (not is_single_entry)
434 stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
438 bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
439 | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
441 -- If we wanted to do eager blackholing with slop filling,
442 -- we'd need to do it at the *end* of a basic block, otherwise
443 -- we overwrite the free variables in the thunk that we still
444 -- need. We have a patch for this from Andy Cheadle, but not
445 -- incorporated yet. --SDM [6/2004]
447 -- Profiling needs slop filling (to support LDV profiling), so
448 -- currently eager blackholing doesn't work with profiling.
450 -- Previously, eager blackholing was enabled when ticky-ticky
451 -- was on. But it didn't work, and it wasn't strictly necessary
452 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
453 -- is unconditionally disabled. -- krc 1/2007
455 eager_blackholing = False
459 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
460 -- Nota Bene: this function does not change Node (even if it's a CAF),
461 -- so that the cost centre in the original closure can still be
462 -- extracted by a subsequent enterCostCentre
463 setupUpdate closure_info code
464 | closureReEntrant closure_info
467 | not (isStaticClosure closure_info)
468 = if closureUpdReqd closure_info
469 then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
470 else do { tickyUpdateFrameOmitted; code }
472 | otherwise -- A static closure
473 = do { tickyUpdateBhCaf closure_info
475 ; if closureUpdReqd closure_info
476 then do -- Blackhole the (updatable) CAF:
477 { upd_closure <- link_caf closure_info True
478 ; pushUpdateFrame upd_closure code }
480 { -- krc: removed some ticky-related code here.
481 ; tickyUpdateFrameOmitted
486 -----------------------------------------------------------------------------
489 -- When a CAF is first entered, it creates a black hole in the heap,
490 -- and updates itself with an indirection to this new black hole.
492 -- We update the CAF with an indirection to a newly-allocated black
493 -- hole in the heap. We also set the blocking queue on the newly
494 -- allocated black hole to be empty.
496 -- Why do we make a black hole in the heap when we enter a CAF?
498 -- - for a generational garbage collector, which needs a fast
499 -- test for whether an updatee is in an old generation or not
501 -- - for the parallel system, which can implement updates more
502 -- easily if the updatee is always in the heap. (allegedly).
504 -- When debugging, we maintain a separate CAF list so we can tell when
505 -- a CAF has been garbage collected.
507 -- newCAF must be called before the itbl ptr is overwritten, since
508 -- newCAF records the old itbl ptr in order to do CAF reverting
509 -- (which Hugs needs to do in order that combined mode works right.)
512 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
513 -- into the "newCAF" RTS procedure, which we call anyway, including
514 -- the allocation of the black-hole indirection closure.
515 -- That way, code size would fall, the CAF-handling code would
516 -- be closer together, and the compiler wouldn't need to know
517 -- about off_indirectee etc.
519 link_caf :: ClosureInfo
520 -> Bool -- True <=> updatable, False <=> single-entry
521 -> FCode CmmExpr -- Returns amode for closure to be updated
522 -- To update a CAF we must allocate a black hole, link the CAF onto the
523 -- CAF list, then update the CAF to point to the fresh black hole.
524 -- This function returns the address of the black hole, so it can be
525 -- updated with the new value when available. The reason for all of this
526 -- is that we only want to update dynamic heap objects, not static ones,
527 -- so that generational GC is easier.
528 link_caf cl_info is_upd = do
529 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
530 ; let use_cc = costCentreFrom (CmmReg nodeReg)
532 ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
533 ; hp_rel <- getHpRelOffset hp_offset
535 -- Call the RTS function newCAF to add the CAF to the CafList
536 -- so that the garbage collector can find them
537 -- This must be done *before* the info table pointer is overwritten,
538 -- because the old info table ptr is needed for reversion
539 ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
540 -- node is live, so save it.
542 -- Overwrite the closure with a (static) indirection
543 -- to the newly-allocated black hole
544 ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
545 , CmmStore (CmmReg nodeReg) ind_static_info ]
549 bh_cl_info :: ClosureInfo
550 bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
551 | otherwise = seCafBlackHoleClosureInfo cl_info
553 ind_static_info :: CmmExpr
554 ind_static_info = mkLblExpr mkIndStaticInfoLabel
556 off_indirectee :: WordOff
557 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
561 %************************************************************************
563 \subsection[CgClosure-Description]{Profiling Closure Description.}
565 %************************************************************************
567 For "global" data constructors the description is simply occurrence
568 name of the data constructor itself. Otherwise it is determined by
569 @closureDescription@ from the let binding information.
572 closureDescription :: Module -- Module
573 -> Name -- Id of closure binding
575 -- Not called for StgRhsCon which have global info tables built in
576 -- CgConTbls.lhs with a description generated from the data constructor
577 closureDescription mod_name name
578 = showSDocDump (char '<' <>
579 (if isExternalName name
580 then ppr name -- ppr will include the module name prefix
581 else pprModule mod_name <> char '.' <> ppr name) <>
583 -- showSDocDump, because we want to see the unique on the Name.