1 -----------------------------------------------------------------------------
3 -- Stg to C-- code generation: bindings
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
16 #include "HsVersions.h"
32 import CoreSyn ( AltCon(..) )
40 import Monad (foldM, liftM)
53 ------------------------------------------------------------------------
55 ------------------------------------------------------------------------
57 -- For closures bound at top level, allocate in static space.
58 -- They should have no free variables.
61 -> CostCentreStack -- Optional cost centre annotation
69 cgTopRhsClosure id ccs _ upd_flag srt args body = do
70 { -- LAY OUT THE OBJECT
72 ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
73 ; srt_info <- getSRTInfo srt
74 ; mod_name <- getModuleName
75 ; let descr = closureDescription mod_name name
76 closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
77 closure_label = mkLocalClosureLabel name (idCafInfo id)
78 cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
79 closure_rep = mkStaticClosureFields closure_info ccs True []
81 -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
82 ; emitDataLits closure_label closure_rep
83 ; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
84 (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
86 -- Don't drop the non-void args until the closure info has been made
87 ; forkClosureBody (closureCodeBody True id closure_info ccs
88 (nonVoidIds args) (length args) body fv_details)
90 ; returnFC cg_id_info }
92 ------------------------------------------------------------------------
93 -- Non-top-level bindings
94 ------------------------------------------------------------------------
96 cgBind :: StgBinding -> FCode ()
97 cgBind (StgNonRec name rhs)
98 = do { ((info, init), body) <- getCodeR $ cgRhs name rhs
99 ; addBindC (cg_id info) info
100 ; emit (init <*> body) }
102 cgBind (StgRec pairs)
103 = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
104 do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
105 ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
106 ; addBindsC new_binds
107 ; emit (catAGraphs inits <*> body) }
109 {- Recursive let-bindings are tricky.
110 Consider the following pseudocode:
111 let x = \_ -> ... y ...
115 For each binding, we need to allocate a closure, and each closure must
116 capture the address of the other closures.
117 We want to generate the following C-- code:
118 // Initialization Code
119 x = hp - 24; // heap address of x's closure
120 y = hp - 40; // heap address of x's closure
121 z = hp - 64; // heap address of x's closure
122 // allocate and initialize x
124 m[hp-16] = y // the closure for x captures y
126 // allocate and initialize y
127 m[hp-32] = z; // the closure for y captures z
129 // allocate and initialize z
132 For each closure, we must generate not only the code to allocate and
133 initialize the closure itself, but also some Initialization Code that
134 sets a variable holding the closure pointer.
135 The complication here is that we don't know the heap offsets a priori,
136 which has two consequences:
137 1. we need a fixpoint
138 2. we can't trivially separate the Initialization Code from the
139 code that compiles the right-hand-sides
141 Note: We don't need this complication with let-no-escapes, because
142 in that case, the names are bound to labels in the environment,
143 and we don't need to emit any code to witness that binding.
147 cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph)
148 -- The Id is passed along so a binding can be set up
149 -- The returned values are the binding for the environment
150 -- and the Initialization Code that witnesses the binding
152 cgRhs name (StgRhsCon maybe_cc con args)
153 = buildDynCon name maybe_cc con args
155 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
156 = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
158 ------------------------------------------------------------------------
159 -- Non-constructor right hand sides
160 ------------------------------------------------------------------------
162 mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
163 -> [NonVoid Id] -- Free vars
167 -> FCode (CgIdInfo, CmmAGraph)
169 {- mkRhsClosure looks for two special forms of the right-hand side:
173 If neither happens, it just calls mkClosureLFInfo. You might think
174 that mkClosureLFInfo should do all this, but it seems wrong for the
175 latter to look at the structure of an expression
179 We look at the body of the closure to see if it's a selector---turgid,
180 but nothing deep. We are looking for a closure of {\em exactly} the
183 ... = [the_fv] \ u [] ->
185 con a_1 ... a_n -> a_i
189 A more generic AP thunk of the form
191 x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
193 A set of these is compiled statically into the RTS, so we just use
194 those. We could extend the idea to thunks where some of the x_i are
195 global ids (and hence not free variables), but this would entail
196 generating a larger thunk. It might be an option for non-optimising
199 We only generate an Ap thunk if all the free variables are pointers,
200 for semi-obvious reasons.
204 ---------- Note [Selectors] ------------------
205 mkRhsClosure bndr cc bi
206 [NonVoid the_fv] -- Just one free var
207 upd_flag -- Updatable thunk
210 body@(StgCase (StgApp scrutinee [{-no args-}])
211 _ _ _ _ -- ignore uniq, etc.
213 [(DataAlt con, params, _use_mask,
214 (StgApp selectee [{-no args-}]))])
215 | the_fv == scrutinee -- Scrutinee is the only free variable
216 && maybeToBool maybe_offset -- Selectee is a component of the tuple
217 && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
218 = -- NOT TRUE: ASSERT(is_single_constructor)
219 -- The simplifier may have statically determined that the single alternative
220 -- is the only possible case and eliminated the others, even if there are
221 -- other constructors in the datatype. It's still ok to make a selector
222 -- thunk in this case, because we *know* which constructor the scrutinee
225 -- srt is discarded; it must be empty
226 cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
228 lf_info = mkSelectorLFInfo bndr offset_into_int
229 (isUpdatable upd_flag)
230 (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
231 -- Just want the layout
232 maybe_offset = assocMaybe params_w_offsets (NonVoid selectee)
233 Just the_offset = maybe_offset
234 offset_into_int = the_offset - fixedHdrSize
236 ---------- Note [Ap thunks] ------------------
237 mkRhsClosure bndr cc bi
241 [] -- No args; a thunk
242 body@(StgApp fun_id args)
244 | args `lengthIs` (arity-1)
245 && all isFollowableArg (map (idCgRep . stripNV) fvs)
246 && isUpdatable upd_flag
247 && arity <= mAX_SPEC_AP_SIZE
250 = cgStdThunk bndr cc bi body lf_info payload
252 lf_info = mkApLFInfo bndr upd_flag arity
253 -- the payload has to be in the correct order, hence we can't
255 payload = StgVarArg fun_id : args
258 ---------- Default case ------------------
259 mkRhsClosure bndr cc _ fvs upd_flag srt args body
260 = do { -- LAY OUT THE OBJECT
261 -- If the binder is itself a free variable, then don't store
262 -- it in the closure. Instead, just bind it to Node on entry.
263 -- NB we can be sure that Node will point to it, because we
264 -- haven't told mkClosureLFInfo about this; so if the binder
265 -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
266 -- stored in the closure itself, so it will make sure that
267 -- Node points to it...
269 is_elem = isIn "cgRhsClosure"
270 bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs
271 reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
275 -- MAKE CLOSURE INFO FOR THIS CLOSURE
276 ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
277 ; mod_name <- getModuleName
278 ; c_srt <- getSRTInfo srt
279 ; let name = idName bndr
280 descr = closureDescription mod_name name
281 fv_details :: [(NonVoid Id, VirtualHpOffset)]
282 (tot_wds, ptr_wds, fv_details)
283 = mkVirtHeapOffsets (isLFThunk lf_info)
284 (addIdReps (map stripNV reduced_fvs))
285 closure_info = mkClosureInfo False -- Not static
286 bndr lf_info tot_wds ptr_wds
289 -- BUILD ITS INFO TABLE AND CODE
291 -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere
292 -- (b) ignore Sequel from context; use empty Sequel
293 -- And compile the body
294 closureCodeBody False bndr closure_info cc (nonVoidIds args)
295 (length args) body fv_details
298 ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
299 ; emit (mkComment $ mkFastString "calling allocDynClosure")
300 ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
301 ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
302 (map toVarArg fv_details)
305 ; return $ (regIdInfo bndr lf_info tmp, init) }
307 -- Use with care; if used inappropriately, it could break invariants.
308 stripNV :: NonVoid a -> a
309 stripNV (NonVoid a) = a
311 -------------------------
314 -> CostCentreStack -- Optional cost centre annotation
315 -> StgBinderInfo -- XXX: not used??
318 -> [StgArg] -- payload
319 -> FCode (CgIdInfo, CmmAGraph)
321 cgStdThunk bndr cc _bndr_info body lf_info payload
322 = do -- AHA! A STANDARD-FORM THUNK
323 { -- LAY OUT THE OBJECT
324 mod_name <- getModuleName
325 ; let (tot_wds, ptr_wds, payload_w_offsets)
326 = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
328 descr = closureDescription mod_name (idName bndr)
329 closure_info = mkClosureInfo False -- Not static
330 bndr lf_info tot_wds ptr_wds
331 NoC_SRT -- No SRT for a std-form closure
334 ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
337 ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
340 ; returnFC $ (regIdInfo bndr lf_info tmp, init) }
342 mkClosureLFInfo :: Id -- The binder
343 -> TopLevelFlag -- True of top level
344 -> [NonVoid Id] -- Free vars
345 -> UpdateFlag -- Update flag
347 -> FCode LambdaFormInfo
348 mkClosureLFInfo bndr top fvs upd_flag args
349 | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag)
350 | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
351 ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) }
354 ------------------------------------------------------------------------
355 -- The code for closures}
356 ------------------------------------------------------------------------
358 closureCodeBody :: Bool -- whether this is a top-level binding
359 -> Id -- the closure's name
360 -> ClosureInfo -- Lots of information about this closure
361 -> CostCentreStack -- Optional cost centre attached to closure
362 -> [NonVoid Id] -- incoming args to the closure
363 -> Int -- arity, including void args
365 -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
368 {- There are two main cases for the code for closures.
370 * If there are *no arguments*, then the closure is a thunk, and not in
371 normal form. So it should set up an update frame (if it is
372 shared). NB: Thunks cannot have a primitive type!
374 * If there is *at least one* argument, then this closure is in
375 normal form, so there is no need to set up an update frame.
377 The Macros for GrAnSim are produced at the beginning of the
378 argSatisfactionCheck (by calling fetchAndReschedule).
379 There info if Node points to closure is available. -- HWL -}
381 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
382 | length args == 0 -- No args i.e. thunk
383 = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
384 (\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
386 closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
387 = ASSERT( length args > 0 )
388 do { -- Allocate the global ticky counter,
389 -- and establish the ticky-counter
390 -- label for this block
391 let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
392 ; emitTickyCounter cl_info (map stripNV args)
393 ; setTickyCtrLabel ticky_ctr_lbl $ do
395 -- Emit the main entry code
396 ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
397 -- Emit the slow-entry code (for entering a closure through a PAP)
398 { mkSlowEntryCode cl_info arg_regs
400 ; let lf_info = closureLFInfo cl_info
401 node_points = nodeMustPointToIt lf_info
402 ; tickyEnterFun cl_info
403 ; whenC node_points (ldvEnterClosure cl_info)
404 ; granYield arg_regs node_points
407 ; entryHeapCheck node arity arg_regs $ do
408 { enterCostCentre cl_info cc body
409 ; fv_bindings <- mapM bind_fv fv_details
410 ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
411 ; cgExpr body }} -- heap check, to reduce live vars over check
415 -- A function closure pointer may be tagged, so we
416 -- must take it into account when accessing the free variables.
417 bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff)
418 bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
420 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
421 load_fvs node lf_info = mapCs (\ (reg, off) ->
422 emit $ mkTaggedObjectLoad reg node off tag)
423 where tag = lfDynTag lf_info
425 -----------------------------------------
426 -- The "slow entry" code for a function. This entry point takes its
427 -- arguments on the stack. It loads the arguments into registers
428 -- according to the calling convention, and jumps to the function's
429 -- normal entry point. The function's closure is assumed to be in
432 -- The slow entry point is used for unknown calls: eg. stg_PAP_entry
434 mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
435 -- If this function doesn't have a specialised ArgDescr, we need
436 -- to generate the function's arg bitmap and slow-entry code.
437 -- Here, we emit the slow-entry code.
438 mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
439 | Just (_, ArgGen _) <- closureFunInfo cl_info
440 = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
442 | otherwise = return ()
444 caf_refs = clHasCafRefs cl_info
445 name = closureName cl_info
446 slow_lbl = mkSlowEntryLabel name caf_refs
447 fast_lbl = enterLocalIdLabel name caf_refs
448 jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
450 mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
452 -----------------------------------------
453 thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
454 LocalReg -> Int -> StgExpr -> FCode ()
455 thunkCode cl_info fv_details cc node arity body
456 = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
457 ; tickyEnterThunk cl_info
458 ; ldvEnterClosure cl_info -- NB: Node always points when profiling
459 ; granThunk node_points
461 -- Heap overflow check
462 ; entryHeapCheck node arity [] $ do
463 { -- Overwrite with black hole if necessary
464 -- but *after* the heap-overflow check
465 whenC (blackHoleOnEntry cl_info && node_points)
466 (blackHoleIt cl_info)
469 ; setupUpdate cl_info node $
470 -- We only enter cc after setting up update so
471 -- that cc of enclosing scope will be recorded
472 -- in update frame CAF/DICT functions will be
473 -- subsumed by this enclosing cc
474 do { enterCostCentre cl_info cc body
475 ; let lf_info = closureLFInfo cl_info
476 ; fv_bindings <- mapM bind_fv fv_details
477 ; load_fvs node lf_info fv_bindings
481 ------------------------------------------------------------------------
482 -- Update and black-hole wrappers
483 ------------------------------------------------------------------------
485 blackHoleIt :: ClosureInfo -> FCode ()
486 -- Only called for closures with no args
487 -- Node points to the closure
488 blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
490 emitBlackHoleCode :: Bool -> FCode ()
491 emitBlackHoleCode is_single_entry
492 | eager_blackholing = do
493 tickyBlackHole (not is_single_entry)
494 emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
498 bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
499 | otherwise = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
501 -- If we wanted to do eager blackholing with slop filling,
502 -- we'd need to do it at the *end* of a basic block, otherwise
503 -- we overwrite the free variables in the thunk that we still
504 -- need. We have a patch for this from Andy Cheadle, but not
505 -- incorporated yet. --SDM [6/2004]
507 -- Profiling needs slop filling (to support LDV profiling), so
508 -- currently eager blackholing doesn't work with profiling.
510 -- Previously, eager blackholing was enabled when ticky-ticky
511 -- was on. But it didn't work, and it wasn't strictly necessary
512 -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
513 -- is unconditionally disabled. -- krc 1/2007
515 eager_blackholing = False
517 setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
518 -- Nota Bene: this function does not change Node (even if it's a CAF),
519 -- so that the cost centre in the original closure can still be
520 -- extracted by a subsequent enterCostCentre
521 setupUpdate closure_info node body
522 | closureReEntrant closure_info
525 | not (isStaticClosure closure_info)
526 = if closureUpdReqd closure_info
527 then do { tickyPushUpdateFrame;
528 ; pushUpdateFrame [CmmReg (CmmLocal node),
529 mkLblExpr mkUpdInfoLabel] body }
530 else do { tickyUpdateFrameOmitted; body}
532 | otherwise -- A static closure
533 = do { tickyUpdateBhCaf closure_info
535 ; if closureUpdReqd closure_info
536 then do -- Blackhole the (updatable) CAF:
537 { upd_closure <- link_caf closure_info True
538 ; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
539 mkLblExpr mkUpdInfoLabel] body }
540 else do {tickyUpdateFrameOmitted; body}
543 -- Push the update frame on the stack in the Entry area,
544 -- leaving room for the return address that is already
545 -- at the old end of the area.
546 pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
547 pushUpdateFrame es body
548 = do updfr <- getUpdFrameOff
549 offset <- foldM push updfr es
550 withUpdFrameOff offset body
552 do emit (mkStore (CmmStackSlot (CallArea Old) base) e)
554 where base = off + widthInBytes (cmmExprWidth e)
556 -----------------------------------------------------------------------------
559 -- When a CAF is first entered, it creates a black hole in the heap,
560 -- and updates itself with an indirection to this new black hole.
562 -- We update the CAF with an indirection to a newly-allocated black
563 -- hole in the heap. We also set the blocking queue on the newly
564 -- allocated black hole to be empty.
566 -- Why do we make a black hole in the heap when we enter a CAF?
568 -- - for a generational garbage collector, which needs a fast
569 -- test for whether an updatee is in an old generation or not
571 -- - for the parallel system, which can implement updates more
572 -- easily if the updatee is always in the heap. (allegedly).
574 -- When debugging, we maintain a separate CAF list so we can tell when
575 -- a CAF has been garbage collected.
577 -- newCAF must be called before the itbl ptr is overwritten, since
578 -- newCAF records the old itbl ptr in order to do CAF reverting
579 -- (which Hugs needs to do in order that combined mode works right.)
582 -- ToDo [Feb 04] This entire link_caf nonsense could all be moved
583 -- into the "newCAF" RTS procedure, which we call anyway, including
584 -- the allocation of the black-hole indirection closure.
585 -- That way, code size would fall, the CAF-handling code would
586 -- be closer together, and the compiler wouldn't need to know
587 -- about off_indirectee etc.
589 link_caf :: ClosureInfo
590 -> Bool -- True <=> updatable, False <=> single-entry
591 -> FCode LocalReg -- Returns amode for closure to be updated
592 -- To update a CAF we must allocate a black hole, link the CAF onto the
593 -- CAF list, then update the CAF to point to the fresh black hole.
594 -- This function returns the address of the black hole, so it can be
595 -- updated with the new value when available. The reason for all of this
596 -- is that we only want to update dynamic heap objects, not static ones,
597 -- so that generational GC is easier.
598 link_caf cl_info _is_upd = do
599 { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
600 ; let use_cc = costCentreFrom (CmmReg nodeReg)
602 ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
605 -- Call the RTS function newCAF to add the CAF to the CafList
606 -- so that the garbage collector can find them
607 -- This must be done *before* the info table pointer is overwritten,
608 -- because the old info table ptr is needed for reversion
609 ; emitRtsCallWithVols (sLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
610 -- node is live, so save it.
612 -- Overwrite the closure with a (static) indirection
613 -- to the newly-allocated black hole
614 ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
615 mkStore (CmmReg nodeReg) ind_static_info)
619 bh_cl_info :: ClosureInfo
620 bh_cl_info = cafBlackHoleClosureInfo cl_info
622 ind_static_info :: CmmExpr
623 ind_static_info = mkLblExpr mkIndStaticInfoLabel
625 off_indirectee :: WordOff
626 off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
629 ------------------------------------------------------------------------
631 ------------------------------------------------------------------------
633 -- For "global" data constructors the description is simply occurrence
634 -- name of the data constructor itself. Otherwise it is determined by
635 -- @closureDescription@ from the let binding information.
637 closureDescription :: Module -- Module
638 -> Name -- Id of closure binding
640 -- Not called for StgRhsCon which have global info tables built in
641 -- CgConTbls.lhs with a description generated from the data constructor
642 closureDescription mod_name name
643 = showSDocDump (char '<' <>
644 (if isExternalName name
645 then ppr name -- ppr will include the module name prefix
646 else pprModule mod_name <> char '.' <> ppr name) <>
648 -- showSDocDump, because we want to see the unique on the Name.