2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 % $Id: CgClosure.lhs,v 1.65 2004/11/26 16:20:03 simonmar 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,
45 import CmdLineOpts ( opt_DoTickyProfiling )
47 import Id ( Id, idName, idType )
49 import Module ( Module, pprModule )
50 import ListSetOps ( minusList )
51 import Util ( isIn, mapAccumL, zipWithEqual )
52 import BasicTypes ( TopLevelFlag(..) )
53 import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE )
58 %********************************************************
60 \subsection[closures-no-free-vars]{Top-level closures}
62 %********************************************************
64 For closures bound at top level, allocate in static space.
65 They should have no free variables.
69 -> CostCentreStack -- Optional cost centre annotation
75 -> FCode (Id, CgIdInfo)
77 cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
78 { -- LAY OUT THE OBJECT
80 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
81 ; srt_info <- getSRTInfo name srt
82 ; mod_name <- moduleName
83 ; let descr = closureDescription mod_name name
84 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
85 closure_label = mkLocalClosureLabel name
86 cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
87 closure_rep = mkStaticClosureFields closure_info ccs True []
89 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
90 ; emitDataLits closure_label closure_rep
91 ; forkClosureBody (closureCodeBody binder_info closure_info
94 ; returnFC (id, cg_id_info) }
97 %********************************************************
99 \subsection[non-top-level-closures]{Non top-level closures}
101 %********************************************************
103 For closures with free vars, allocate in heap.
108 -> CostCentreStack -- Optional cost centre annotation
114 -> [StgArg] -- payload
115 -> FCode (Id, CgIdInfo)
117 cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
118 = do -- AHA! A STANDARD-FORM THUNK
119 { -- LAY OUT THE OBJECT
120 amodes <- getArgAmodes payload
121 ; mod_name <- moduleName
122 ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes
124 descr = closureDescription mod_name (idName bndr)
125 closure_info = mkClosureInfo False -- Not static
126 bndr lf_info tot_wds ptr_wds
127 NoC_SRT -- No SRT for a std-form closure
130 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
133 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
136 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
139 Here's the general case.
143 -> CostCentreStack -- Optional cost centre annotation
150 -> FCode (Id, CgIdInfo)
152 cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
153 { -- LAY OUT THE OBJECT
154 -- If the binder is itself a free variable, then don't store
155 -- it in the closure. Instead, just bind it to Node on entry.
156 -- NB we can be sure that Node will point to it, because we
157 -- havn't told mkClosureLFInfo about this; so if the binder
158 -- *was* a free var of its RHS, mkClosureLFInfo thinks it *is*
159 -- stored in the closure itself, so it will make sure that
160 -- Node points to it...
163 is_elem = isIn "cgRhsClosure"
164 bndr_is_a_fv = bndr `is_elem` fvs
165 reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
168 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
169 ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
170 ; srt_info <- getSRTInfo name srt
171 ; mod_name <- moduleName
172 ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
173 (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos)
174 add_rep info = (cgIdInfoArgRep info, info)
176 descr = closureDescription mod_name name
177 closure_info = mkClosureInfo False -- Not static
178 bndr lf_info tot_wds ptr_wds
181 -- BUILD ITS INFO TABLE AND CODE
182 ; forkClosureBody (do
184 let bind_fv (info, offset)
185 = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
186 ; mapCs bind_fv bind_details
188 -- Bind the binder itself, if it is a free var
189 ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
192 ; closureCodeBody bndr_info closure_info cc args body })
196 to_amode (info, offset) = do { amode <- idInfoToAmode info
197 ; return (amode, offset) }
198 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
199 ; amodes_w_offsets <- mapFCs to_amode bind_details
200 ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
203 ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
206 mkClosureLFInfo :: Id -- The binder
207 -> TopLevelFlag -- True of top level
209 -> UpdateFlag -- Update flag
211 -> FCode LambdaFormInfo
212 mkClosureLFInfo bndr top fvs upd_flag args
213 | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
214 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
215 ; return (mkLFReEntrant top fvs args arg_descr) }
219 %************************************************************************
221 \subsection[code-for-closures]{The code for closures}
223 %************************************************************************
226 closureCodeBody :: StgBinderInfo
227 -> ClosureInfo -- Lots of information about this closure
228 -> CostCentreStack -- Optional cost centre attached to closure
234 There are two main cases for the code for closures. If there are {\em
235 no arguments}, then the closure is a thunk, and not in normal form.
236 So it should set up an update frame (if it is shared).
237 NB: Thunks cannot have a primitive type!
240 closureCodeBody binder_info cl_info cc [] body = do
241 { body_absC <- getCgStmts $ do
242 { tickyEnterThunk cl_info
243 ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
244 ; thunkWrapper cl_info $ do
245 -- We only enter cc after setting up update so
246 -- that cc of enclosing scope will be recorded
247 -- in update frame CAF/DICT functions will be
248 -- subsumed by this enclosing cc
249 { enterCostCentre cl_info cc body
253 ; emitClosureCodeAndInfoTable cl_info [] body_absC }
256 If there is /at least one argument/, then this closure is in
257 normal form, so there is no need to set up an update frame.
259 The Macros for GrAnSim are produced at the beginning of the
260 argSatisfactionCheck (by calling fetchAndReschedule). There info if
261 Node points to closure is available. -- HWL
264 closureCodeBody binder_info cl_info cc args body = do
265 { -- Get the current virtual Sp (it might not be zero,
266 -- eg. if we're compiling a let-no-escape).
268 ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
269 (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
271 -- Allocate the global ticky counter
272 ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
273 ; emitTickyCounter cl_info args sp_top
275 -- ...and establish the ticky-counter
276 -- label for this block
277 ; setTickyCtrLabel ticky_ctr_lbl $ do
279 -- Emit the slow-entry code
280 { reg_save_code <- mkSlowEntryCode cl_info reg_args
282 -- Emit the main entry code
284 mkFunEntryCode cl_info cc reg_args stk_args
285 sp_top reg_save_code body
286 ; emitClosureCodeAndInfoTable cl_info [] blks
291 mkFunEntryCode :: ClosureInfo
293 -> [(Id,GlobalReg)] -- Args in regs
294 -> [(Id,VirtualSpOffset)] -- Args on stack
295 -> VirtualSpOffset -- Last allocated word on stack
296 -> CmmStmts -- Register-save code in case of GC
299 -- The main entry code for the closure
300 mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
301 { -- Bind args to regs/stack as appropriate,
302 -- and record expected position of sps
303 ; bindArgsToRegs reg_args
304 ; bindArgsToStack stk_args
305 ; setRealAndVirtualSp sp_top
307 -- Enter the cost-centre, if required
308 -- ToDo: It's not clear why this is outside the funWrapper,
309 -- but the tickyEnterFun is inside. Perhaps we can put
311 ; enterCostCentre cl_info cc body
314 ; funWrapper cl_info reg_args reg_save_code $ do
315 { tickyEnterFun cl_info
320 The "slow entry" code for a function. This entry point takes its
321 arguments on the stack. It loads the arguments into registers
322 according to the calling convention, and jumps to the function's
323 normal entry point. The function's closure is assumed to be in
326 The slow entry point is used in two places:
328 (a) unknown calls: eg. stg_PAP_entry
329 (b) returning from a heap-check failure
332 mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
333 -- If this function doesn't have a specialised ArgDescr, we need
334 -- to generate the function's arg bitmap, slow-entry code, and
335 -- register-save code for the heap-check failure
336 -- Here, we emit the slow-entry code, and
337 -- return the register-save assignments
338 mkSlowEntryCode cl_info reg_args
339 | Just (_, ArgGen _) <- closureFunInfo cl_info
340 = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
341 ; return save_stmts }
342 | otherwise = return noStmts
344 name = closureName cl_info
345 slow_lbl = mkSlowEntryLabel name
347 load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
348 save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
350 reps_w_regs :: [(CgRep,GlobalReg)]
351 reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
352 (final_stk_offset, stk_offsets)
353 = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
356 load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
357 mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
358 (CmmLoad (cmmRegOffW spReg offset)
361 save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
362 mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
363 CmmStore (cmmRegOffW spReg offset)
364 (CmmReg (CmmGlobal reg))
366 stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
367 stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
368 jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
372 %************************************************************************
374 \subsubsection[closure-code-wrappers]{Wrappers around closure code}
376 %************************************************************************
379 thunkWrapper:: ClosureInfo -> Code -> Code
380 thunkWrapper closure_info thunk_code = do
381 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
383 -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
384 -- (we prefer fetchAndReschedule-style context switches to yield ones)
386 then granFetchAndReschedule [] node_points
387 else granYield [] node_points
389 -- Stack and/or heap checks
390 ; thunkEntryChecks closure_info $ do
391 { -- Overwrite with black hole if necessary
392 whenC (blackHoleOnEntry closure_info && node_points)
393 (blackHoleIt closure_info)
394 ; setupUpdate closure_info thunk_code }
395 -- setupUpdate *encloses* the thunk_code
398 funWrapper :: ClosureInfo -- Closure whose code body this is
399 -> [(Id,GlobalReg)] -- List of argument registers (if any)
400 -> CmmStmts -- reg saves for the heap check failure
401 -> Code -- Body of function being compiled
403 funWrapper closure_info arg_regs reg_save_code fun_body = do
404 { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
406 -- Enter for Ldv profiling
407 ; whenC node_points (ldvEnter (CmmReg nodeReg))
409 -- GranSim yeild poin
410 ; granYield arg_regs node_points
412 -- Heap and/or stack checks wrap the function body
413 ; funEntryChecks closure_info reg_save_code
419 %************************************************************************
421 \subsubsubsection[update-and-BHs]{Update and black-hole wrappers}
423 %************************************************************************
427 blackHoleIt :: ClosureInfo -> Code
428 -- Only called for closures with no args
429 -- Node points to the closure
430 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
432 emitBlackHoleCode :: Bool -> Code
433 emitBlackHoleCode is_single_entry
434 | eager_blackholing = do
435 tickyBlackHole (not is_single_entry)
436 stmtC (CmmStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
440 bh_lbl | is_single_entry = mkRtsDataLabel SLIT("stg_SE_BLACKHOLE_info")
441 | otherwise = mkRtsDataLabel SLIT("stg_BLACKHOLE_info")
443 -- If we wanted to do eager blackholing with slop filling,
444 -- we'd need to do it at the *end* of a basic block, otherwise
445 -- we overwrite the free variables in the thunk that we still
446 -- need. We have a patch for this from Andy Cheadle, but not
447 -- incorporated yet. --SDM [6/2004]
449 -- Profiling needs slop filling (to support LDV profiling), so
450 -- currently eager blackholing doesn't work with profiling.
452 -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
453 -- single-entry thunks.
455 | opt_DoTickyProfiling = True
461 setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
462 -- Nota Bene: this function does not change Node (even if it's a CAF),
463 -- so that the cost centre in the original closure can still be
464 -- extracted by a subsequent enterCostCentre
465 setupUpdate closure_info code
466 | closureReEntrant closure_info
469 | not (isStaticClosure closure_info)
470 = if closureUpdReqd closure_info
471 then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
472 else do { tickyUpdateFrameOmitted; code }
474 | otherwise -- A static closure
475 = do { tickyUpdateBhCaf closure_info
477 ; if closureUpdReqd closure_info
478 then do -- Blackhole the (updatable) CAF:
479 { upd_closure <- link_caf closure_info True
480 ; pushUpdateFrame upd_closure code }
482 { -- No update reqd, you'd think we don't need to
483 -- black-hole it. But when ticky-ticky is on, we
484 -- black-hole it regardless, to catch errors in which
485 -- an allegedly single-entry closure is entered twice
487 -- We discard the pointer returned by link_caf, because
488 -- we don't push an update frame
489 whenC opt_DoTickyProfiling -- Blackhole even a SE CAF
490 (link_caf closure_info False >> nopC)
491 ; tickyUpdateFrameOmitted
496 -----------------------------------------------------------------------------
499 -- When a CAF is first entered, it creates a black hole in the heap,
500 -- and updates itself with an indirection to this new black hole.
502 -- We update the CAF with an indirection to a newly-allocated black
503 -- hole in the heap. We also set the blocking queue on the newly
504 -- allocated black hole to be empty.
506 -- Why do we make a black hole in the heap when we enter a CAF?
508 -- - for a generational garbage collector, which needs a fast
509 -- test for whether an updatee is in an old generation or not
511 -- - for the parallel system, which can implement updates more
512 -- easily if the updatee is always in the heap. (allegedly).
514 -- When debugging, we maintain a separate CAF list so we can tell when
515 -- a CAF has been garbage collected.
517 -- newCAF must be called before the itbl ptr is overwritten, since
518 -- newCAF records the old itbl ptr in order to do CAF reverting
519 -- (which Hugs needs to do in order that combined mode works right.)
522 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
523 -- into the "newCAF" RTS procedure, which we call anyway, including
524 -- the allocation of the black-hole indirection closure.
525 -- That way, code size would fall, the CAF-handling code would
526 -- be closer together, and the compiler wouldn't need to know
527 -- about off_indirectee etc.
529 link_caf :: ClosureInfo
530 -> Bool -- True <=> updatable, False <=> single-entry
531 -> FCode CmmExpr -- Returns amode for closure to be updated
532 -- To update a CAF we must allocate a black hole, link the CAF onto the
533 -- CAF list, then update the CAF to point to the fresh black hole.
534 -- This function returns the address of the black hole, so it can be
535 -- updated with the new value when available. The reason for all of this
536 -- is that we only want to update dynamic heap objects, not static ones,
537 -- so that generational GC is easier.
538 link_caf cl_info is_upd = do
539 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
540 ; let use_cc = costCentreFrom (CmmReg nodeReg)
542 ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
543 ; hp_rel <- getHpRelOffset hp_offset
545 -- Call the RTS function newCAF to add the CAF to the CafList
546 -- so that the garbage collector can find them
547 -- This must be done *before* the info table pointer is overwritten,
548 -- because the old info table ptr is needed for reversion
549 ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
550 -- node is live, so save it.
552 -- Overwrite the closure with a (static) indirection
553 -- to the newly-allocated black hole
554 ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
555 , CmmStore (CmmReg nodeReg) ind_static_info ]
559 bh_cl_info :: ClosureInfo
560 bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
561 | otherwise = seCafBlackHoleClosureInfo cl_info
563 ind_static_info :: CmmExpr
564 ind_static_info = mkLblExpr mkIndStaticInfoLabel
566 off_indirectee :: WordOff
567 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
571 %************************************************************************
573 \subsection[CgClosure-Description]{Profiling Closure Description.}
575 %************************************************************************
577 For "global" data constructors the description is simply occurrence
578 name of the data constructor itself. Otherwise it is determined by
579 @closureDescription@ from the let binding information.
582 closureDescription :: Module -- Module
583 -> Name -- Id of closure binding
585 -- Not called for StgRhsCon which have global info tables built in
586 -- CgConTbls.lhs with a description generated from the data constructor
587 closureDescription mod_name name
588 = showSDoc (hcat [char '<', pprModule mod_name,
589 char '.', ppr name, char '>'])