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.
13 -- The above warning supression flag is a temporary kludge.
14 -- While working on this module you are encouraged to remove it and fix
15 -- any warnings in the module. See
16 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
19 module CgClosure ( cgTopRhsClosure,
25 #include "HsVersions.h"
27 import {-# SOURCE #-} CgExpr ( cgExpr )
61 %********************************************************
63 \subsection[closures-no-free-vars]{Top-level closures}
65 %********************************************************
67 For closures bound at top level, allocate in static space.
68 They should have no free variables.
72 -> CostCentreStack -- Optional cost centre annotation
77 -> FCode (Id, CgIdInfo)
79 cgTopRhsClosure id ccs binder_info upd_flag args body = do
80 { -- LAY OUT THE OBJECT
82 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
83 ; srt_info <- getSRTInfo
84 ; mod_name <- getModuleName
85 ; let descr = closureDescription mod_name name
86 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
87 closure_label = mkLocalClosureLabel name $ idCafInfo id
88 cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
89 closure_rep = mkStaticClosureFields closure_info ccs True []
91 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
92 ; emitDataLits closure_label closure_rep
93 ; forkClosureBody (closureCodeBody binder_info closure_info
96 ; returnFC (id, cg_id_info) }
99 %********************************************************
101 \subsection[non-top-level-closures]{Non top-level closures}
103 %********************************************************
105 For closures with free vars, allocate in heap.
110 -> CostCentreStack -- Optional cost centre annotation
116 -> [StgArg] -- payload
117 -> FCode (Id, CgIdInfo)
119 cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
120 = do -- AHA! A STANDARD-FORM THUNK
121 { -- LAY OUT THE OBJECT
122 amodes <- getArgAmodes payload
123 ; mod_name <- getModuleName
124 ; let (tot_wds, ptr_wds, amodes_w_offsets)
125 = mkVirtHeapOffsets (isLFThunk lf_info) amodes
127 descr = closureDescription mod_name (idName bndr)
128 closure_info = mkClosureInfo False -- Not static
129 bndr lf_info tot_wds ptr_wds
130 NoC_SRT -- No SRT for a std-form closure
133 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
136 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
139 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
142 Here's the general case.
146 -> CostCentreStack -- Optional cost centre annotation
152 -> FCode (Id, CgIdInfo)
154 cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
155 { -- LAY OUT THE OBJECT
156 -- If the binder is itself a free variable, then don't store
157 -- it in the closure. Instead, just bind it to Node on entry.
158 -- NB we can be sure that Node will point to it, because we
159 -- havn't told mkClosureLFInfo about this; so if the binder
160 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
161 -- stored in the closure itself, so it will make sure that
162 -- Node points to it...
165 is_elem = isIn "cgRhsClosure"
166 bndr_is_a_fv = bndr `is_elem` fvs
167 reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
170 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
171 ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
172 ; srt_info <- getSRTInfo
173 ; mod_name <- getModuleName
174 ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
175 (tot_wds, ptr_wds, bind_details)
176 = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
178 add_rep info = (cgIdInfoArgRep info, info)
180 descr = closureDescription mod_name name
181 closure_info = mkClosureInfo False -- Not static
182 bndr lf_info tot_wds ptr_wds
185 -- BUILD ITS INFO TABLE AND CODE
186 ; forkClosureBody (do
189 -- A function closure pointer may be tagged, so we
190 -- must take it into account when accessing the free variables.
191 mbtag = tagForArity (length args)
192 bind_fv (info, offset)
194 = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
196 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
197 ; mapCs bind_fv bind_details
199 -- Bind the binder itself, if it is a free var
200 ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
203 ; closureCodeBody bndr_info closure_info cc args body })
207 to_amode (info, offset) = do { amode <- idInfoToAmode info
208 ; return (amode, offset) }
209 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
210 ; amodes_w_offsets <- mapFCs to_amode bind_details
211 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
214 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
217 mkClosureLFInfo :: Id -- The binder
218 -> TopLevelFlag -- True of top level
220 -> UpdateFlag -- Update flag
222 -> FCode LambdaFormInfo
223 mkClosureLFInfo bndr top fvs upd_flag args
224 | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
225 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
226 ; return (mkLFReEntrant top fvs args arg_descr) }
230 %************************************************************************
232 \subsection[code-for-closures]{The code for closures}
234 %************************************************************************
237 closureCodeBody :: StgBinderInfo
238 -> ClosureInfo -- Lots of information about this closure
239 -> CostCentreStack -- Optional cost centre attached to closure
245 There are two main cases for the code for closures. If there are {\em
246 no arguments}, then the closure is a thunk, and not in normal form.
247 So it should set up an update frame (if it is shared).
248 NB: Thunks cannot have a primitive type!
251 closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
252 { body_absC <- getCgStmts $ do
253 { tickyEnterThunk cl_info
254 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
255 ; thunkWrapper cl_info $ do
256 -- We only enter cc after setting up update so
257 -- that cc of enclosing scope will be recorded
258 -- in update frame CAF/DICT functions will be
259 -- subsumed by this enclosing cc
260 { enterCostCentre cl_info cc body
261 ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body]
265 ; emitClosureCodeAndInfoTable cl_info [] body_absC }
268 If there is /at least one argument/, then this closure is in
269 normal form, so there is no need to set up an update frame.
271 The Macros for GrAnSim are produced at the beginning of the
272 argSatisfactionCheck (by calling fetchAndReschedule). There info if
273 Node points to closure is available. -- HWL
276 closureCodeBody binder_info cl_info cc args body
277 = ASSERT( length args > 0 )
278 do { -- Get the current virtual Sp (it might not be zero,
279 -- eg. if we're compiling a let-no-escape).
281 ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
282 (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
284 -- Allocate the global ticky counter
285 ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
286 ; emitTickyCounter cl_info args sp_top
288 -- ...and establish the ticky-counter
289 -- label for this block
290 ; setTickyCtrLabel ticky_ctr_lbl $ do
292 -- Emit the slow-entry code
293 { reg_save_code <- mkSlowEntryCode cl_info reg_args
295 -- Emit the main entry code
297 mkFunEntryCode cl_info cc reg_args stk_args
298 sp_top reg_save_code body
299 ; emitClosureCodeAndInfoTable cl_info [] blks
304 mkFunEntryCode :: ClosureInfo
306 -> [(Id,GlobalReg)] -- Args in regs
307 -> [(Id,VirtualSpOffset)] -- Args on stack
308 -> VirtualSpOffset -- Last allocated word on stack
309 -> CmmStmts -- Register-save code in case of GC
312 -- The main entry code for the closure
313 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
314 { -- Bind args to regs/stack as appropriate,
315 -- and record expected position of sps
316 ; bindArgsToRegs reg_args
317 ; bindArgsToStack stk_args
318 ; setRealAndVirtualSp sp_top
320 -- Enter the cost-centre, if required
321 -- ToDo: It's not clear why this is outside the funWrapper,
322 -- but the tickyEnterFun is inside. Perhaps we can put
324 ; enterCostCentre cl_info cc body
327 ; funWrapper cl_info reg_args reg_save_code $ do
328 { tickyEnterFun cl_info
333 The "slow entry" code for a function. This entry point takes its
334 arguments on the stack. It loads the arguments into registers
335 according to the calling convention, and jumps to the function's
336 normal entry point. The function's closure is assumed to be in
339 The slow entry point is used in two places:
341 (a) unknown calls: eg. stg_PAP_entry
342 (b) returning from a heap-check failure
345 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
346 -- If this function doesn't have a specialised ArgDescr, we need
347 -- to generate the function's arg bitmap, slow-entry code, and
348 -- register-save code for the heap-check failure
349 -- Here, we emit the slow-entry code, and
350 -- return the register-save assignments
351 mkSlowEntryCode cl_info reg_args
352 | Just (_, ArgGen _) <- closureFunInfo cl_info
353 = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
354 ; return save_stmts }
355 | otherwise = return noStmts
357 name = closureName cl_info
358 has_caf_refs = clHasCafRefs cl_info
359 slow_lbl = mkSlowEntryLabel name has_caf_refs
361 load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
362 save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
364 reps_w_regs :: [(CgRep,GlobalReg)]
365 reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
366 (final_stk_offset, stk_offsets)
367 = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
370 load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
371 mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
372 (CmmLoad (cmmRegOffW spReg offset)
375 save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
376 mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg )
377 CmmStore (cmmRegOffW spReg offset)
378 (CmmReg (CmmGlobal reg))
380 stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
381 stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
382 jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) []
386 %************************************************************************
388 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
390 %************************************************************************
393 thunkWrapper:: ClosureInfo -> Code -> Code
394 thunkWrapper closure_info thunk_code = do
395 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
397 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
398 -- (we prefer fetchAndReschedule-style context switches to yield ones)
400 then granFetchAndReschedule [] node_points
401 else granYield [] node_points
403 -- Stack and/or heap checks
404 ; thunkEntryChecks closure_info $ do
405 { -- Overwrite with black hole if necessary
406 whenC (blackHoleOnEntry closure_info && node_points)
407 (blackHoleIt closure_info)
408 ; setupUpdate closure_info thunk_code }
409 -- setupUpdate *encloses* the thunk_code
412 funWrapper :: ClosureInfo -- Closure whose code body this is
413 -> [(Id,GlobalReg)] -- List of argument registers (if any)
414 -> CmmStmts -- reg saves for the heap check failure
415 -> Code -- Body of function being compiled
417 funWrapper closure_info arg_regs reg_save_code fun_body = do
418 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
421 -- Debugging: check that R1 has the correct tag
422 ; let tag = funTag closure_info
423 ; whenC (tag /= 0 && node_points) $ do
425 stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
426 CmmLit (mkIntCLit tag)]) l)
427 stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
431 -- Enter for Ldv profiling
432 ; whenC node_points (ldvEnterClosure closure_info)
434 -- GranSim yeild poin
435 ; granYield arg_regs node_points
437 -- Heap and/or stack checks wrap the function body
438 ; funEntryChecks closure_info reg_save_code
444 %************************************************************************
446 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
448 %************************************************************************
452 blackHoleIt :: ClosureInfo -> Code
453 -- Only called for closures with no args
454 -- Node points to the closure
455 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
457 emitBlackHoleCode :: Bool -> Code
458 emitBlackHoleCode is_single_entry = do
460 dflags <- getDynFlags
462 -- If we wanted to do eager blackholing with slop filling,
463 -- we'd need to do it at the *end* of a basic block, otherwise
464 -- we overwrite the free variables in the thunk that we still
465 -- need. We have a patch for this from Andy Cheadle, but not
466 -- incorporated yet. --SDM [6/2004]
468 -- Profiling needs slop filling (to support LDV profiling), so
469 -- currently eager blackholing doesn't work with profiling.
471 -- Previously, eager blackholing was enabled when ticky-ticky
472 -- was on. But it didn't work, and it wasn't strictly necessary
473 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
474 -- is unconditionally disabled. -- krc 1/2007
476 let eager_blackholing = not opt_SccProfilingOn
477 && dopt Opt_EagerBlackHoling dflags
481 tickyBlackHole (not is_single_entry)
482 let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo)
483 stmtC (CmmStore (CmmReg nodeReg) bh_info)
489 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
490 -- Nota Bene: this function does not change Node (even if it's a CAF),
491 -- so that the cost centre in the original closure can still be
492 -- extracted by a subsequent enterCostCentre
493 setupUpdate closure_info code
494 | closureReEntrant closure_info
497 | not (isStaticClosure closure_info)
498 = if closureUpdReqd closure_info
499 then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
500 else do { tickyUpdateFrameOmitted; code }
502 | otherwise -- A static closure
503 = do { tickyUpdateBhCaf closure_info
505 ; if closureUpdReqd closure_info
506 then do -- Blackhole the (updatable) CAF:
507 { upd_closure <- link_caf closure_info True
508 ; pushUpdateFrame upd_closure code }
510 { -- krc: removed some ticky-related code here.
511 ; tickyUpdateFrameOmitted
516 -----------------------------------------------------------------------------
519 -- When a CAF is first entered, it creates a black hole in the heap,
520 -- and updates itself with an indirection to this new black hole.
522 -- We update the CAF with an indirection to a newly-allocated black
523 -- hole in the heap. We also set the blocking queue on the newly
524 -- allocated black hole to be empty.
526 -- Why do we make a black hole in the heap when we enter a CAF?
528 -- - for a generational garbage collector, which needs a fast
529 -- test for whether an updatee is in an old generation or not
531 -- - for the parallel system, which can implement updates more
532 -- easily if the updatee is always in the heap. (allegedly).
534 -- When debugging, we maintain a separate CAF list so we can tell when
535 -- a CAF has been garbage collected.
537 -- newCAF must be called before the itbl ptr is overwritten, since
538 -- newCAF records the old itbl ptr in order to do CAF reverting
539 -- (which Hugs needs to do in order that combined mode works right.)
542 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
543 -- into the "newCAF" RTS procedure, which we call anyway, including
544 -- the allocation of the black-hole indirection closure.
545 -- That way, code size would fall, the CAF-handling code would
546 -- be closer together, and the compiler wouldn't need to know
547 -- about off_indirectee etc.
549 link_caf :: ClosureInfo
550 -> Bool -- True <=> updatable, False <=> single-entry
551 -> FCode CmmExpr -- Returns amode for closure to be updated
552 -- To update a CAF we must allocate a black hole, link the CAF onto the
553 -- CAF list, then update the CAF to point to the fresh black hole.
554 -- This function returns the address of the black hole, so it can be
555 -- updated with the new value when available. The reason for all of this
556 -- is that we only want to update dynamic heap objects, not static ones,
557 -- so that generational GC is easier.
558 link_caf cl_info is_upd = do
559 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
560 ; let use_cc = costCentreFrom (CmmReg nodeReg)
562 ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
563 ; hp_rel <- getHpRelOffset hp_offset
565 -- Call the RTS function newCAF to add the CAF to the CafList
566 -- so that the garbage collector can find them
567 -- This must be done *before* the info table pointer is overwritten,
568 -- because the old info table ptr is needed for reversion
569 ; emitRtsCallWithVols (sLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False
570 -- node is live, so save it.
572 -- Overwrite the closure with a (static) indirection
573 -- to the newly-allocated black hole
574 ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
575 , CmmStore (CmmReg nodeReg) ind_static_info ]
579 bh_cl_info :: ClosureInfo
580 bh_cl_info = cafBlackHoleClosureInfo cl_info
582 ind_static_info :: CmmExpr
583 ind_static_info = mkLblExpr mkIndStaticInfoLabel
585 off_indirectee :: WordOff
586 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
590 %************************************************************************
592 \subsection[CgClosure-Description]{Profiling Closure Description.}
594 %************************************************************************
596 For "global" data constructors the description is simply occurrence
597 name of the data constructor itself. Otherwise it is determined by
598 @closureDescription@ from the let binding information.
601 closureDescription :: Module -- Module
602 -> Name -- Id of closure binding
604 -- Not called for StgRhsCon which have global info tables built in
605 -- CgConTbls.lhs with a description generated from the data constructor
606 closureDescription mod_name name
607 = showSDocDump (char '<' <>
608 (if isExternalName name
609 then ppr name -- ppr will include the module name prefix
610 else pprModule mod_name <> char '.' <> ppr name) <>
612 -- showSDocDump, because we want to see the unique on the Name.