2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.64 2004/09/30 10:35:39 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,
19 #include "HsVersions.h"
21 import {-# SOURCE #-} CgExpr ( cgExpr )
26 import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp,
28 import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre,
31 import CgParallel ( granYield, granFetchAndReschedule )
32 import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo )
33 import CgCallConv ( assignCallRegs, mkArgDescr )
34 import CgUtils ( emitDataLits, addIdReps, cmmRegOffW,
36 import ClosureInfo -- lots and lots of stuff
37 import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff,
39 import MachOp ( MachHint(..) )
41 import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
43 import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel,
44 mkSlowEntryLabel, mkIndStaticInfoLabel )
46 import CmdLineOpts ( opt_DoTickyProfiling )
48 import Id ( Id, idName, idType )
50 import Module ( Module, pprModule )
51 import ListSetOps ( minusList )
52 import Util ( isIn, mapAccumL, zipWithEqual )
53 import BasicTypes ( TopLevelFlag(..) )
54 import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE )
59 %********************************************************
61 \subsection[closures-no-free-vars]{Top-level closures}
63 %********************************************************
65 For closures bound at top level, allocate in static space.
66 They should have no free variables.
70 -> CostCentreStack -- Optional cost centre annotation
76 -> FCode (Id, CgIdInfo)
78 cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
79 { -- LAY OUT THE OBJECT
81 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
82 ; srt_info <- getSRTInfo name srt
83 ; mod_name <- moduleName
84 ; let descr = closureDescription mod_name name
85 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
86 closure_label = mkClosureLabel 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 <- moduleName
123 ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes
125 descr = closureDescription mod_name (idName bndr)
126 closure_info = mkClosureInfo False -- Not static
127 bndr lf_info tot_wds ptr_wds
128 NoC_SRT -- No SRT for a std-form closure
131 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
134 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
137 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
140 Here's the general case.
144 -> CostCentreStack -- Optional cost centre annotation
151 -> FCode (Id, CgIdInfo)
153 cgRhsClosure bndr cc bndr_info srt 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 name srt
172 ; mod_name <- moduleName
173 ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
174 (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos)
175 add_rep info = (cgIdInfoArgRep info, info)
177 descr = closureDescription mod_name name
178 closure_info = mkClosureInfo False -- Not static
179 bndr lf_info tot_wds ptr_wds
182 -- BUILD ITS INFO TABLE AND CODE
183 ; forkClosureBody (do
185 let bind_fv (info, offset)
186 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
187 ; mapCs bind_fv bind_details
189 -- Bind the binder itself, if it is a free var
190 ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
193 ; closureCodeBody bndr_info closure_info cc args body })
197 to_amode (info, offset) = do { amode <- idInfoToAmode info
198 ; return (amode, offset) }
199 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
200 ; amodes_w_offsets <- mapFCs to_amode bind_details
201 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
204 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
207 mkClosureLFInfo :: Id -- The binder
208 -> TopLevelFlag -- True of top level
210 -> UpdateFlag -- Update flag
212 -> FCode LambdaFormInfo
213 mkClosureLFInfo bndr top fvs upd_flag args
214 | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
215 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
216 ; return (mkLFReEntrant top fvs args arg_descr) }
220 %************************************************************************
222 \subsection[code-for-closures]{The code for closures}
224 %************************************************************************
227 closureCodeBody :: StgBinderInfo
228 -> ClosureInfo -- Lots of information about this closure
229 -> CostCentreStack -- Optional cost centre attached to closure
235 There are two main cases for the code for closures. If there are {\em
236 no arguments}, then the closure is a thunk, and not in normal form.
237 So it should set up an update frame (if it is shared).
238 NB: Thunks cannot have a primitive type!
241 closureCodeBody binder_info cl_info cc [] body = do
242 { body_absC <- getCgStmts $ do
243 { tickyEnterThunk cl_info
244 ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
245 ; thunkWrapper cl_info $ do
246 -- We only enter cc after setting up update so
247 -- that cc of enclosing scope will be recorded
248 -- in update frame CAF/DICT functions will be
249 -- subsumed by this enclosing cc
250 { enterCostCentre cl_info cc body
254 ; emitClosureCodeAndInfoTable cl_info [] body_absC }
257 If there is /at least one argument/, then this closure is in
258 normal form, so there is no need to set up an update frame.
260 The Macros for GrAnSim are produced at the beginning of the
261 argSatisfactionCheck (by calling fetchAndReschedule). There info if
262 Node points to closure is available. -- HWL
265 closureCodeBody binder_info cl_info cc args body = do
266 { -- Get the current virtual Sp (it might not be zero,
267 -- eg. if we're compiling a let-no-escape).
269 ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
270 (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
272 -- Allocate the global ticky counter
273 ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
274 ; emitTickyCounter cl_info args sp_top
276 -- ...and establish the ticky-counter
277 -- label for this block
278 ; setTickyCtrLabel ticky_ctr_lbl $ do
280 -- Emit the slow-entry code
281 { reg_save_code <- mkSlowEntryCode cl_info reg_args
283 -- Emit the main entry code
285 mkFunEntryCode cl_info cc reg_args stk_args
286 sp_top reg_save_code body
287 ; emitClosureCodeAndInfoTable cl_info [] blks
292 mkFunEntryCode :: ClosureInfo
294 -> [(Id,GlobalReg)] -- Args in regs
295 -> [(Id,VirtualSpOffset)] -- Args on stack
296 -> VirtualSpOffset -- Last allocated word on stack
297 -> CmmStmts -- Register-save code in case of GC
300 -- The main entry code for the closure
301 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
302 { -- Bind args to regs/stack as appropriate,
303 -- and record expected position of sps
304 ; bindArgsToRegs reg_args
305 ; bindArgsToStack stk_args
306 ; setRealAndVirtualSp sp_top
308 -- Enter the cost-centre, if required
309 -- ToDo: It's not clear why this is outside the funWrapper,
310 -- but the tickyEnterFun is inside. Perhaps we can put
312 ; enterCostCentre cl_info cc body
315 ; funWrapper cl_info reg_args reg_save_code $ do
316 { tickyEnterFun cl_info
321 The "slow entry" code for a function. This entry point takes its
322 arguments on the stack. It loads the arguments into registers
323 according to the calling convention, and jumps to the function's
324 normal entry point. The function's closure is assumed to be in
327 The slow entry point is used in two places:
329 (a) unknown calls: eg. stg_PAP_entry
330 (b) returning from a heap-check failure
333 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
334 -- If this function doesn't have a specialised ArgDescr, we need
335 -- to generate the function's arg bitmap, slow-entry code, and
336 -- register-save code for the heap-check failure
337 -- Here, we emit the slow-entry code, and
338 -- return the register-save assignments
339 mkSlowEntryCode cl_info reg_args
340 | Just (_, ArgGen _) <- closureFunInfo cl_info
341 = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
342 ; return save_stmts }
343 | otherwise = return noStmts
345 name = closureName cl_info
346 slow_lbl = mkSlowEntryLabel name
348 load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
349 save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
351 reps_w_regs :: [(CgRep,GlobalReg)]
352 reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
353 (final_stk_offset, stk_offsets)
354 = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
357 load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
358 mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
359 (CmmLoad (cmmRegOffW spReg offset)
362 save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
363 mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
364 CmmStore (cmmRegOffW spReg offset)
365 (CmmReg (CmmGlobal reg))
367 stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
368 stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
369 jump_to_entry = CmmJump (mkLblExpr (enterIdLabel name)) []
373 %************************************************************************
375 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
377 %************************************************************************
380 thunkWrapper:: ClosureInfo -> Code -> Code
381 thunkWrapper closure_info thunk_code = do
382 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
384 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
385 -- (we prefer fetchAndReschedule-style context switches to yield ones)
387 then granFetchAndReschedule [] node_points
388 else granYield [] node_points
390 -- Stack and/or heap checks
391 ; thunkEntryChecks closure_info $ do
392 { -- Overwrite with black hole if necessary
393 whenC (blackHoleOnEntry closure_info && node_points)
394 (blackHoleIt closure_info)
395 ; setupUpdate closure_info thunk_code }
396 -- setupUpdate *encloses* the thunk_code
399 funWrapper :: ClosureInfo -- Closure whose code body this is
400 -> [(Id,GlobalReg)] -- List of argument registers (if any)
401 -> CmmStmts -- reg saves for the heap check failure
402 -> Code -- Body of function being compiled
404 funWrapper closure_info arg_regs reg_save_code fun_body = do
405 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
407 -- Enter for Ldv profiling
408 ; whenC node_points (ldvEnter (CmmReg nodeReg))
410 -- GranSim yeild poin
411 ; granYield arg_regs node_points
413 -- Heap and/or stack checks wrap the function body
414 ; funEntryChecks closure_info reg_save_code
420 %************************************************************************
422 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
424 %************************************************************************
428 blackHoleIt :: ClosureInfo -> Code
429 -- Only called for closures with no args
430 -- Node points to the closure
431 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
433 emitBlackHoleCode :: Bool -> Code
434 emitBlackHoleCode is_single_entry
435 | eager_blackholing = do
436 tickyBlackHole (not is_single_entry)
437 stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
441 bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
442 | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
444 -- If we wanted to do eager blackholing with slop filling,
445 -- we'd need to do it at the *end* of a basic block, otherwise
446 -- we overwrite the free variables in the thunk that we still
447 -- need. We have a patch for this from Andy Cheadle, but not
448 -- incorporated yet. --SDM [6/2004]
450 -- Profiling needs slop filling (to support LDV profiling), so
451 -- currently eager blackholing doesn't work with profiling.
453 -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
454 -- single-entry thunks.
456 | opt_DoTickyProfiling = True
462 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
463 -- Nota Bene: this function does not change Node (even if it's a CAF),
464 -- so that the cost centre in the original closure can still be
465 -- extracted by a subsequent enterCostCentre
466 setupUpdate closure_info code
467 | closureReEntrant closure_info
470 | not (isStaticClosure closure_info)
471 = if closureUpdReqd closure_info
472 then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
473 else do { tickyUpdateFrameOmitted; code }
475 | otherwise -- A static closure
476 = do { tickyUpdateBhCaf closure_info
478 ; if closureUpdReqd closure_info
479 then do -- Blackhole the (updatable) CAF:
480 { upd_closure <- link_caf closure_info True
481 ; pushUpdateFrame upd_closure code }
483 { -- No update reqd, you'd think we don't need to
484 -- black-hole it. But when ticky-ticky is on, we
485 -- black-hole it regardless, to catch errors in which
486 -- an allegedly single-entry closure is entered twice
488 -- We discard the pointer returned by link_caf, because
489 -- we don't push an update frame
490 whenC opt_DoTickyProfiling -- Blackhole even a SE CAF
491 (link_caf closure_info False >> nopC)
492 ; tickyUpdateFrameOmitted
497 -----------------------------------------------------------------------------
500 -- When a CAF is first entered, it creates a black hole in the heap,
501 -- and updates itself with an indirection to this new black hole.
503 -- We update the CAF with an indirection to a newly-allocated black
504 -- hole in the heap. We also set the blocking queue on the newly
505 -- allocated black hole to be empty.
507 -- Why do we make a black hole in the heap when we enter a CAF?
509 -- - for a generational garbage collector, which needs a fast
510 -- test for whether an updatee is in an old generation or not
512 -- - for the parallel system, which can implement updates more
513 -- easily if the updatee is always in the heap. (allegedly).
515 -- When debugging, we maintain a separate CAF list so we can tell when
516 -- a CAF has been garbage collected.
518 -- newCAF must be called before the itbl ptr is overwritten, since
519 -- newCAF records the old itbl ptr in order to do CAF reverting
520 -- (which Hugs needs to do in order that combined mode works right.)
523 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
524 -- into the "newCAF" RTS procedure, which we call anyway, including
525 -- the allocation of the black-hole indirection closure.
526 -- That way, code size would fall, the CAF-handling code would
527 -- be closer together, and the compiler wouldn't need to know
528 -- about off_indirectee etc.
530 link_caf :: ClosureInfo
531 -> Bool -- True <=> updatable, False <=> single-entry
532 -> FCode CmmExpr -- Returns amode for closure to be updated
533 -- To update a CAF we must allocate a black hole, link the CAF onto the
534 -- CAF list, then update the CAF to point to the fresh black hole.
535 -- This function returns the address of the black hole, so it can be
536 -- updated with the new value when available. The reason for all of this
537 -- is that we only want to update dynamic heap objects, not static ones,
538 -- so that generational GC is easier.
539 link_caf cl_info is_upd = do
540 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
541 ; let use_cc = costCentreFrom (CmmReg nodeReg)
543 ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
544 ; hp_rel <- getHpRelOffset hp_offset
546 -- Call the RTS function newCAF to add the CAF to the CafList
547 -- so that the garbage collector can find them
548 -- This must be done *before* the info table pointer is overwritten,
549 -- because the old info table ptr is needed for reversion
550 ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
551 -- node is live, so save it.
553 -- Overwrite the closure with a (static) indirection
554 -- to the newly-allocated black hole
555 ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
556 , CmmStore (CmmReg nodeReg) ind_static_info ]
560 bh_cl_info :: ClosureInfo
561 bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
562 | otherwise = seCafBlackHoleClosureInfo cl_info
564 ind_static_info :: CmmExpr
565 ind_static_info = mkLblExpr mkIndStaticInfoLabel
567 off_indirectee :: WordOff
568 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
572 %************************************************************************
574 \subsection[CgClosure-Description]{Profiling Closure Description.}
576 %************************************************************************
578 For "global" data constructors the description is simply occurrence
579 name of the data constructor itself. Otherwise it is determined by
580 @closureDescription@ from the let binding information.
583 closureDescription :: Module -- Module
584 -> Name -- Id of closure binding
586 -- Not called for StgRhsCon which have global info tables built in
587 -- CgConTbls.lhs with a description generated from the data constructor
588 closureDescription mod_name name
589 = showSDoc (hcat [char '<', pprModule mod_name,
590 char '.', ppr name, char '>'])