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 )
60 %********************************************************
62 \subsection[closures-no-free-vars]{Top-level closures}
64 %********************************************************
66 For closures bound at top level, allocate in static space.
67 They should have no free variables.
71 -> CostCentreStack -- Optional cost centre annotation
76 -> FCode (Id, CgIdInfo)
78 cgTopRhsClosure id ccs binder_info upd_flag args body = do
79 { -- LAY OUT THE OBJECT
81 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
82 ; srt_info <- getSRTInfo
83 ; mod_name <- getModuleName
84 ; let descr = closureDescription mod_name name
85 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
86 closure_label = mkLocalClosureLabel name
87 cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
88 closure_rep = mkStaticClosureFields closure_info ccs True []
90 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
91 ; emitDataLits closure_label closure_rep
92 ; forkClosureBody (closureCodeBody binder_info closure_info
95 ; returnFC (id, cg_id_info) }
98 %********************************************************
100 \subsection[non-top-level-closures]{Non top-level closures}
102 %********************************************************
104 For closures with free vars, allocate in heap.
109 -> CostCentreStack -- Optional cost centre annotation
115 -> [StgArg] -- payload
116 -> FCode (Id, CgIdInfo)
118 cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
119 = do -- AHA! A STANDARD-FORM THUNK
120 { -- LAY OUT THE OBJECT
121 amodes <- getArgAmodes payload
122 ; mod_name <- getModuleName
123 ; let (tot_wds, ptr_wds, amodes_w_offsets)
124 = mkVirtHeapOffsets (isLFThunk lf_info) amodes
126 descr = closureDescription mod_name (idName bndr)
127 closure_info = mkClosureInfo False -- Not static
128 bndr lf_info tot_wds ptr_wds
129 NoC_SRT -- No SRT for a std-form closure
132 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
135 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
138 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
141 Here's the general case.
145 -> CostCentreStack -- Optional cost centre annotation
151 -> FCode (Id, CgIdInfo)
153 cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
154 { -- LAY OUT THE OBJECT
155 -- If the binder is itself a free variable, then don't store
156 -- it in the closure. Instead, just bind it to Node on entry.
157 -- NB we can be sure that Node will point to it, because we
158 -- havn't told mkClosureLFInfo about this; so if the binder
159 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
160 -- stored in the closure itself, so it will make sure that
161 -- Node points to it...
164 is_elem = isIn "cgRhsClosure"
165 bndr_is_a_fv = bndr `is_elem` fvs
166 reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
169 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
170 ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
171 ; srt_info <- getSRTInfo
172 ; mod_name <- getModuleName
173 ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
174 (tot_wds, ptr_wds, bind_details)
175 = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
177 add_rep info = (cgIdInfoArgRep info, info)
179 descr = closureDescription mod_name name
180 closure_info = mkClosureInfo False -- Not static
181 bndr lf_info tot_wds ptr_wds
184 -- BUILD ITS INFO TABLE AND CODE
185 ; forkClosureBody (do
188 -- A function closure pointer may be tagged, so we
189 -- must take it into account when accessing the free variables.
190 mbtag = tagForArity (length args)
191 bind_fv (info, offset)
193 = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
195 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
196 ; mapCs bind_fv bind_details
198 -- Bind the binder itself, if it is a free var
199 ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
202 ; closureCodeBody bndr_info closure_info cc args body })
206 to_amode (info, offset) = do { amode <- idInfoToAmode info
207 ; return (amode, offset) }
208 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
209 ; amodes_w_offsets <- mapFCs to_amode bind_details
210 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
213 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
216 mkClosureLFInfo :: Id -- The binder
217 -> TopLevelFlag -- True of top level
219 -> UpdateFlag -- Update flag
221 -> FCode LambdaFormInfo
222 mkClosureLFInfo bndr top fvs upd_flag args
223 | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
224 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
225 ; return (mkLFReEntrant top fvs args arg_descr) }
229 %************************************************************************
231 \subsection[code-for-closures]{The code for closures}
233 %************************************************************************
236 closureCodeBody :: StgBinderInfo
237 -> ClosureInfo -- Lots of information about this closure
238 -> CostCentreStack -- Optional cost centre attached to closure
244 There are two main cases for the code for closures. If there are {\em
245 no arguments}, then the closure is a thunk, and not in normal form.
246 So it should set up an update frame (if it is shared).
247 NB: Thunks cannot have a primitive type!
250 closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
251 { body_absC <- getCgStmts $ do
252 { tickyEnterThunk cl_info
253 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
254 ; thunkWrapper cl_info $ do
255 -- We only enter cc after setting up update so
256 -- that cc of enclosing scope will be recorded
257 -- in update frame CAF/DICT functions will be
258 -- subsumed by this enclosing cc
259 { enterCostCentre cl_info cc body
263 ; emitClosureCodeAndInfoTable cl_info [] body_absC }
266 If there is /at least one argument/, then this closure is in
267 normal form, so there is no need to set up an update frame.
269 The Macros for GrAnSim are produced at the beginning of the
270 argSatisfactionCheck (by calling fetchAndReschedule). There info if
271 Node points to closure is available. -- HWL
274 closureCodeBody binder_info cl_info cc args body
275 = ASSERT( length args > 0 )
276 do { -- Get the current virtual Sp (it might not be zero,
277 -- eg. if we're compiling a let-no-escape).
279 ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
280 (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
282 -- Allocate the global ticky counter
283 ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
284 ; emitTickyCounter cl_info args sp_top
286 -- ...and establish the ticky-counter
287 -- label for this block
288 ; setTickyCtrLabel ticky_ctr_lbl $ do
290 -- Emit the slow-entry code
291 { reg_save_code <- mkSlowEntryCode cl_info reg_args
293 -- Emit the main entry code
295 mkFunEntryCode cl_info cc reg_args stk_args
296 sp_top reg_save_code body
297 ; emitClosureCodeAndInfoTable cl_info [] blks
302 mkFunEntryCode :: ClosureInfo
304 -> [(Id,GlobalReg)] -- Args in regs
305 -> [(Id,VirtualSpOffset)] -- Args on stack
306 -> VirtualSpOffset -- Last allocated word on stack
307 -> CmmStmts -- Register-save code in case of GC
310 -- The main entry code for the closure
311 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
312 { -- Bind args to regs/stack as appropriate,
313 -- and record expected position of sps
314 ; bindArgsToRegs reg_args
315 ; bindArgsToStack stk_args
316 ; setRealAndVirtualSp sp_top
318 -- Enter the cost-centre, if required
319 -- ToDo: It's not clear why this is outside the funWrapper,
320 -- but the tickyEnterFun is inside. Perhaps we can put
322 ; enterCostCentre cl_info cc body
325 ; funWrapper cl_info reg_args reg_save_code $ do
326 { tickyEnterFun cl_info
331 The "slow entry" code for a function. This entry point takes its
332 arguments on the stack. It loads the arguments into registers
333 according to the calling convention, and jumps to the function's
334 normal entry point. The function's closure is assumed to be in
337 The slow entry point is used in two places:
339 (a) unknown calls: eg. stg_PAP_entry
340 (b) returning from a heap-check failure
343 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
344 -- If this function doesn't have a specialised ArgDescr, we need
345 -- to generate the function's arg bitmap, slow-entry code, and
346 -- register-save code for the heap-check failure
347 -- Here, we emit the slow-entry code, and
348 -- return the register-save assignments
349 mkSlowEntryCode cl_info reg_args
350 | Just (_, ArgGen _) <- closureFunInfo cl_info
351 = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
352 ; return save_stmts }
353 | otherwise = return noStmts
355 name = closureName cl_info
356 slow_lbl = mkSlowEntryLabel name
358 load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
359 save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
361 reps_w_regs :: [(CgRep,GlobalReg)]
362 reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
363 (final_stk_offset, stk_offsets)
364 = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
367 load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
368 mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
369 (CmmLoad (cmmRegOffW spReg offset)
372 save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
373 mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
374 CmmStore (cmmRegOffW spReg offset)
375 (CmmReg (CmmGlobal reg))
377 stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
378 stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
379 jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
383 %************************************************************************
385 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
387 %************************************************************************
390 thunkWrapper:: ClosureInfo -> Code -> Code
391 thunkWrapper closure_info thunk_code = do
392 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
394 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
395 -- (we prefer fetchAndReschedule-style context switches to yield ones)
397 then granFetchAndReschedule [] node_points
398 else granYield [] node_points
400 -- Stack and/or heap checks
401 ; thunkEntryChecks closure_info $ do
402 { -- Overwrite with black hole if necessary
403 whenC (blackHoleOnEntry closure_info && node_points)
404 (blackHoleIt closure_info)
405 ; setupUpdate closure_info thunk_code }
406 -- setupUpdate *encloses* the thunk_code
409 funWrapper :: ClosureInfo -- Closure whose code body this is
410 -> [(Id,GlobalReg)] -- List of argument registers (if any)
411 -> CmmStmts -- reg saves for the heap check failure
412 -> Code -- Body of function being compiled
414 funWrapper closure_info arg_regs reg_save_code fun_body = do
415 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
418 -- Debugging: check that R1 has the correct tag
419 ; let tag = funTag closure_info
420 ; whenC (tag /= 0 && node_points) $ do
422 stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
423 CmmLit (mkIntCLit tag)]) l)
424 stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
428 -- Enter for Ldv profiling
429 ; whenC node_points (ldvEnterClosure closure_info)
431 -- GranSim yeild poin
432 ; granYield arg_regs node_points
434 -- Heap and/or stack checks wrap the function body
435 ; funEntryChecks closure_info reg_save_code
441 %************************************************************************
443 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
445 %************************************************************************
449 blackHoleIt :: ClosureInfo -> Code
450 -- Only called for closures with no args
451 -- Node points to the closure
452 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
454 emitBlackHoleCode :: Bool -> Code
455 emitBlackHoleCode is_single_entry
456 | eager_blackholing = do
457 tickyBlackHole (not is_single_entry)
458 stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
462 bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
463 | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
465 -- If we wanted to do eager blackholing with slop filling,
466 -- we'd need to do it at the *end* of a basic block, otherwise
467 -- we overwrite the free variables in the thunk that we still
468 -- need. We have a patch for this from Andy Cheadle, but not
469 -- incorporated yet. --SDM [6/2004]
471 -- Profiling needs slop filling (to support LDV profiling), so
472 -- currently eager blackholing doesn't work with profiling.
474 -- Previously, eager blackholing was enabled when ticky-ticky
475 -- was on. But it didn't work, and it wasn't strictly necessary
476 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
477 -- is unconditionally disabled. -- krc 1/2007
479 eager_blackholing = False
483 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
484 -- Nota Bene: this function does not change Node (even if it's a CAF),
485 -- so that the cost centre in the original closure can still be
486 -- extracted by a subsequent enterCostCentre
487 setupUpdate closure_info code
488 | closureReEntrant closure_info
491 | not (isStaticClosure closure_info)
492 = if closureUpdReqd closure_info
493 then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
494 else do { tickyUpdateFrameOmitted; code }
496 | otherwise -- A static closure
497 = do { tickyUpdateBhCaf closure_info
499 ; if closureUpdReqd closure_info
500 then do -- Blackhole the (updatable) CAF:
501 { upd_closure <- link_caf closure_info True
502 ; pushUpdateFrame upd_closure code }
504 { -- krc: removed some ticky-related code here.
505 ; tickyUpdateFrameOmitted
510 -----------------------------------------------------------------------------
513 -- When a CAF is first entered, it creates a black hole in the heap,
514 -- and updates itself with an indirection to this new black hole.
516 -- We update the CAF with an indirection to a newly-allocated black
517 -- hole in the heap. We also set the blocking queue on the newly
518 -- allocated black hole to be empty.
520 -- Why do we make a black hole in the heap when we enter a CAF?
522 -- - for a generational garbage collector, which needs a fast
523 -- test for whether an updatee is in an old generation or not
525 -- - for the parallel system, which can implement updates more
526 -- easily if the updatee is always in the heap. (allegedly).
528 -- When debugging, we maintain a separate CAF list so we can tell when
529 -- a CAF has been garbage collected.
531 -- newCAF must be called before the itbl ptr is overwritten, since
532 -- newCAF records the old itbl ptr in order to do CAF reverting
533 -- (which Hugs needs to do in order that combined mode works right.)
536 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
537 -- into the "newCAF" RTS procedure, which we call anyway, including
538 -- the allocation of the black-hole indirection closure.
539 -- That way, code size would fall, the CAF-handling code would
540 -- be closer together, and the compiler wouldn't need to know
541 -- about off_indirectee etc.
543 link_caf :: ClosureInfo
544 -> Bool -- True <=> updatable, False <=> single-entry
545 -> FCode CmmExpr -- Returns amode for closure to be updated
546 -- To update a CAF we must allocate a black hole, link the CAF onto the
547 -- CAF list, then update the CAF to point to the fresh black hole.
548 -- This function returns the address of the black hole, so it can be
549 -- updated with the new value when available. The reason for all of this
550 -- is that we only want to update dynamic heap objects, not static ones,
551 -- so that generational GC is easier.
552 link_caf cl_info is_upd = do
553 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
554 ; let use_cc = costCentreFrom (CmmReg nodeReg)
556 ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
557 ; hp_rel <- getHpRelOffset hp_offset
559 -- Call the RTS function newCAF to add the CAF to the CafList
560 -- so that the garbage collector can find them
561 -- This must be done *before* the info table pointer is overwritten,
562 -- because the old info table ptr is needed for reversion
563 ; emitRtsCallWithVols SLIT("newCAF") [CmmHinted (CmmReg nodeReg) PtrHint] [node] False
564 -- node is live, so save it.
566 -- Overwrite the closure with a (static) indirection
567 -- to the newly-allocated black hole
568 ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
569 , CmmStore (CmmReg nodeReg) ind_static_info ]
573 bh_cl_info :: ClosureInfo
574 bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
575 | otherwise = seCafBlackHoleClosureInfo cl_info
577 ind_static_info :: CmmExpr
578 ind_static_info = mkLblExpr mkIndStaticInfoLabel
580 off_indirectee :: WordOff
581 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
585 %************************************************************************
587 \subsection[CgClosure-Description]{Profiling Closure Description.}
589 %************************************************************************
591 For "global" data constructors the description is simply occurrence
592 name of the data constructor itself. Otherwise it is determined by
593 @closureDescription@ from the let binding information.
596 closureDescription :: Module -- Module
597 -> Name -- Id of closure binding
599 -- Not called for StgRhsCon which have global info tables built in
600 -- CgConTbls.lhs with a description generated from the data constructor
601 closureDescription mod_name name
602 = showSDocDump (char '<' <>
603 (if isExternalName name
604 then ppr name -- ppr will include the module name prefix
605 else pprModule mod_name <> char '.' <> ppr name) <>
607 -- showSDocDump, because we want to see the unique on the Name.