--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Stg to C-- code generation: bindings
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module StgCmmBind (
+ cgTopRhsClosure,
+ cgBind,
+ emitBlackHoleCode
+ ) where
+
+#include "HsVersions.h"
+
+import StgCmmMonad
+import StgCmmExpr
+import StgCmmEnv
+import StgCmmCon
+import StgCmmHeap
+import StgCmmProf
+import StgCmmTicky
+import StgCmmGran
+import StgCmmLayout
+import StgCmmUtils
+import StgCmmClosure
+
+import MkZipCfgCmm
+import CoreSyn ( AltCon(..) )
+import SMRep
+import Cmm
+import CmmUtils
+import CLabel
+import StgSyn
+import CostCentre
+import Id
+import Name
+import Module
+import ListSetOps
+import Util
+import BasicTypes
+import Constants
+import Outputable
+import FastString
+import Maybes
+
+import Data.List
+
+------------------------------------------------------------------------
+-- Top-level bindings
+------------------------------------------------------------------------
+
+-- For closures bound at top level, allocate in static space.
+-- They should have no free variables.
+
+cgTopRhsClosure :: Id
+ -> CostCentreStack -- Optional cost centre annotation
+ -> StgBinderInfo
+ -> UpdateFlag
+ -> SRT
+ -> [Id] -- Args
+ -> StgExpr
+ -> FCode (Id, CgIdInfo)
+
+cgTopRhsClosure id ccs binder_info upd_flag srt args body = do
+ { -- LAY OUT THE OBJECT
+ let name = idName id
+ ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
+ ; srt_info <- getSRTInfo srt
+ ; mod_name <- getModuleName
+ ; let descr = closureDescription mod_name name
+ closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
+ closure_label = mkLocalClosureLabel name (idCafInfo id)
+ cg_id_info = litIdInfo id lf_info (CmmLabel closure_label)
+ closure_rep = mkStaticClosureFields closure_info ccs True []
+
+ -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
+ ; emitDataLits closure_label closure_rep
+ ; forkClosureBody $ do
+ { node <- bindToReg id lf_info
+ ; closureCodeBody binder_info closure_info
+ ccs srt_info node args body }
+
+ ; returnFC (id, cg_id_info) }
+
+------------------------------------------------------------------------
+-- Non-top-level bindings
+------------------------------------------------------------------------
+
+cgBind :: StgBinding -> FCode ()
+cgBind (StgNonRec name rhs)
+ = do { (name, info) <- cgRhs name rhs
+ ; addBindC name info }
+
+cgBind (StgRec pairs)
+ = do { new_binds <- fixC (\ new_binds ->
+ do { addBindsC new_binds
+ ; listFCs [ cgRhs b e | (b,e) <- pairs ] })
+ ; addBindsC new_binds }
+
+--------------------
+cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+ -- The Id is passed along so a binding can be set up
+
+cgRhs name (StgRhsCon maybe_cc con args)
+ = do { idinfo <- buildDynCon name maybe_cc con args
+ ; return (name, idinfo) }
+
+cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
+ = mkRhsClosure name cc bi fvs upd_flag srt args body
+
+------------------------------------------------------------------------
+-- Non-constructor right hand sides
+------------------------------------------------------------------------
+
+mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo
+ -> [Id] -- Free vars
+ -> UpdateFlag -> SRT
+ -> [Id] -- Args
+ -> StgExpr
+ -> FCode (Id, CgIdInfo)
+
+{- mkRhsClosure looks for two special forms of the right-hand side:
+ a) selector thunks
+ b) AP thunks
+
+If neither happens, it just calls mkClosureLFInfo. You might think
+that mkClosureLFInfo should do all this, but it seems wrong for the
+latter to look at the structure of an expression
+
+Note [Selectors]
+~~~~~~~~~~~~~~~~
+We look at the body of the closure to see if it's a selector---turgid,
+but nothing deep. We are looking for a closure of {\em exactly} the
+form:
+
+... = [the_fv] \ u [] ->
+ case the_fv of
+ con a_1 ... a_n -> a_i
+
+Note [Ap thunks]
+~~~~~~~~~~~~~~~~
+A more generic AP thunk of the form
+
+ x = [ x_1...x_n ] \.. [] -> x_1 ... x_n
+
+A set of these is compiled statically into the RTS, so we just use
+those. We could extend the idea to thunks where some of the x_i are
+global ids (and hence not free variables), but this would entail
+generating a larger thunk. It might be an option for non-optimising
+compilation, though.
+
+We only generate an Ap thunk if all the free variables are pointers,
+for semi-obvious reasons.
+
+-}
+
+---------- Note [Selectors] ------------------
+mkRhsClosure bndr cc bi
+ [the_fv] -- Just one free var
+ upd_flag -- Updatable thunk
+ _srt
+ [] -- A thunk
+ body@(StgCase (StgApp scrutinee [{-no args-}])
+ _ _ _ _ -- ignore uniq, etc.
+ (AlgAlt _)
+ [(DataAlt con, params, _use_mask,
+ (StgApp selectee [{-no args-}]))])
+ | the_fv == scrutinee -- Scrutinee is the only free variable
+ && maybeToBool maybe_offset -- Selectee is a component of the tuple
+ && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
+ = -- NOT TRUE: ASSERT(is_single_constructor)
+ -- The simplifier may have statically determined that the single alternative
+ -- is the only possible case and eliminated the others, even if there are
+ -- other constructors in the datatype. It's still ok to make a selector
+ -- thunk in this case, because we *know* which constructor the scrutinee
+ -- will evaluate to.
+ --
+ -- srt is discarded; it must be empty
+ cgStdThunk bndr cc bi body lf_info [StgVarArg the_fv]
+ where
+ lf_info = mkSelectorLFInfo bndr offset_into_int
+ (isUpdatable upd_flag)
+ (_, params_w_offsets) = layOutDynConstr con (addIdReps params)
+ -- Just want the layout
+ maybe_offset = assocMaybe params_w_offsets selectee
+ Just the_offset = maybe_offset
+ offset_into_int = the_offset - fixedHdrSize
+
+---------- Note [Ap thunks] ------------------
+mkRhsClosure bndr cc bi
+ fvs
+ upd_flag
+ _srt
+ [] -- No args; a thunk
+ body@(StgApp fun_id args)
+
+ | args `lengthIs` (arity-1)
+ && all isFollowableArg (map idCgRep fvs)
+ && isUpdatable upd_flag
+ && arity <= mAX_SPEC_AP_SIZE
+
+ -- Ha! an Ap thunk
+ = cgStdThunk bndr cc bi body lf_info payload
+ where
+ lf_info = mkApLFInfo bndr upd_flag arity
+ -- the payload has to be in the correct order, hence we can't
+ -- just use the fvs.
+ payload = StgVarArg fun_id : args
+ arity = length fvs
+
+---------- Default case ------------------
+mkRhsClosure bndr cc bi fvs upd_flag srt args body
+ = do { -- LAY OUT THE OBJECT
+ -- If the binder is itself a free variable, then don't store
+ -- it in the closure. Instead, just bind it to Node on entry.
+ -- NB we can be sure that Node will point to it, because we
+ -- havn't told mkClosureLFInfo about this; so if the binder
+ -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is*
+ -- stored in the closure itself, so it will make sure that
+ -- Node points to it...
+ ; let
+ is_elem = isIn "cgRhsClosure"
+ bndr_is_a_fv = bndr `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ | otherwise = fvs
+
+
+ -- MAKE CLOSURE INFO FOR THIS CLOSURE
+ ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+ ; mod_name <- getModuleName
+ ; c_srt <- getSRTInfo srt
+ ; let name = idName bndr
+ descr = closureDescription mod_name name
+ fv_details :: [(Id, VirtualHpOffset)]
+ (tot_wds, ptr_wds, fv_details)
+ = mkVirtHeapOffsets (isLFThunk lf_info)
+ (addIdReps reduced_fvs)
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ c_srt descr
+
+ -- BUILD ITS INFO TABLE AND CODE
+ ; forkClosureBody $ do
+ { -- Bind the binder itself
+ -- It does no harm to have it in the envt even if
+ -- it's not a free variable; and we need a reg for it
+ node <- bindToReg bndr lf_info
+
+ -- Bind the free variables
+ ; mapCs (bind_fv node) fv_details
+
+ -- And compile the body
+ ; closureCodeBody bi closure_info cc c_srt node args body }
+
+ -- BUILD THE OBJECT
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
+ ; emit (mkComment $ mkFastString "calling allocDynClosure")
+ ; tmp <- allocDynClosure closure_info use_cc blame_cc
+ (mapFst StgVarArg fv_details)
+
+ -- RETURN
+ ; return (bndr, regIdInfo bndr lf_info tmp) }
+ where
+ -- A function closure pointer may be tagged, so we
+ -- must take it into account when accessing the free variables.
+ tag = tagForArity (length args)
+
+ bind_fv node (id, off)
+ = do { reg <- rebindToReg id
+ ; emit $ mkTaggedObjectLoad reg node off tag }
+
+-------------------------
+cgStdThunk
+ :: Id
+ -> CostCentreStack -- Optional cost centre annotation
+ -> StgBinderInfo -- XXX: not used??
+ -> StgExpr
+ -> LambdaFormInfo
+ -> [StgArg] -- payload
+ -> FCode (Id, CgIdInfo)
+
+cgStdThunk bndr cc _bndr_info body lf_info payload
+ = do -- AHA! A STANDARD-FORM THUNK
+ { -- LAY OUT THE OBJECT
+ mod_name <- getModuleName
+ ; let (tot_wds, ptr_wds, payload_w_offsets)
+ = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
+
+ descr = closureDescription mod_name (idName bndr)
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ NoC_SRT -- No SRT for a std-form closure
+ descr
+
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
+
+ -- BUILD THE OBJECT
+ ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets
+
+ -- RETURN
+ ; returnFC (bndr, regIdInfo bndr lf_info tmp) }
+
+mkClosureLFInfo :: Id -- The binder
+ -> TopLevelFlag -- True of top level
+ -> [Id] -- Free vars
+ -> UpdateFlag -- Update flag
+ -> [Id] -- Args
+ -> FCode LambdaFormInfo
+mkClosureLFInfo bndr top fvs upd_flag args
+ | null args = return (mkLFThunk (idType bndr) top fvs upd_flag)
+ | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args
+ ; return (mkLFReEntrant top fvs args arg_descr) }
+
+
+------------------------------------------------------------------------
+-- The code for closures}
+------------------------------------------------------------------------
+
+closureCodeBody :: StgBinderInfo -- XXX: unused?
+ -> ClosureInfo -- Lots of information about this closure
+ -> CostCentreStack -- Optional cost centre attached to closure
+ -> C_SRT
+ -> LocalReg -- The closure itself; first argument
+ -- The Id is in scope already, bound to this reg
+ -> [Id]
+ -> StgExpr
+ -> FCode ()
+
+{- There are two main cases for the code for closures.
+
+* If there are *no arguments*, then the closure is a thunk, and not in
+ normal form. So it should set up an update frame (if it is
+ shared). NB: Thunks cannot have a primitive type!
+
+* If there is *at least one* argument, then this closure is in
+ normal form, so there is no need to set up an update frame.
+
+ The Macros for GrAnSim are produced at the beginning of the
+ argSatisfactionCheck (by calling fetchAndReschedule).
+ There info if Node points to closure is available. -- HWL -}
+
+closureCodeBody _binder_info cl_info cc srt node args body
+ | null args -- No args i.e. thunk
+ = do { code <- getCode $ thunkCode cl_info cc srt node body
+ ; emitClosureCodeAndInfoTable cl_info [node] code }
+
+closureCodeBody _binder_info cl_info cc srt node args body
+ = ASSERT( length args > 0 )
+ do { -- Allocate the global ticky counter,
+ -- and establish the ticky-counter
+ -- label for this block
+ let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
+ ; emitTickyCounter cl_info args
+ ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+-- -- XXX: no slow-entry code for now
+-- -- Emit the slow-entry code
+-- { reg_save_code <- mkSlowEntryCode cl_info reg_args
+
+ -- Emit the main entry code
+ ; let node_points = nodeMustPointToIt (closureLFInfo cl_info)
+ ; arg_regs <- bindArgsToRegs args
+ ; blks <- forkProc $ getCode $ do
+ { enterCostCentre cl_info cc body
+ ; tickyEnterFun cl_info
+ ; whenC node_points (ldvEnterClosure cl_info)
+ ; granYield arg_regs node_points
+
+ -- Main payload
+ ; entryHeapCheck node arg_regs srt $
+ cgExpr body }
+
+ ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks
+ }
+
+{-
+-----------------------------------------
+-- The "slow entry" code for a function. This entry point takes its
+-- arguments on the stack. It loads the arguments into registers
+-- according to the calling convention, and jumps to the function's
+-- normal entry point. The function's closure is assumed to be in
+-- R1/node.
+--
+-- The slow entry point is used in two places:
+--
+-- (a) unknown calls: eg. stg_PAP_entry
+-- (b) returning from a heap-check failure
+
+mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts
+-- If this function doesn't have a specialised ArgDescr, we need
+-- to generate the function's arg bitmap, slow-entry code, and
+-- register-save code for the heap-check failure
+-- Here, we emit the slow-entry code, and
+-- return the register-save assignments
+mkSlowEntryCode cl_info reg_args
+ | Just (_, ArgGen _) <- closureFunInfo cl_info
+ = do { emitSimpleProc slow_lbl (emitStmts load_stmts)
+ ; return save_stmts }
+ | otherwise = return noStmts
+ where
+ name = closureName cl_info
+ slow_lbl = mkSlowEntryLabel name
+
+ load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
+ save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
+
+ reps_w_regs :: [(CgRep,GlobalReg)]
+ reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args]
+ (final_stk_offset, stk_offsets)
+ = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off))
+ 0 reps_w_regs
+
+ load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets
+ mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg)
+ (CmmLoad (cmmRegOffW spReg offset)
+ (argMachRep rep))
+
+ save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
+ mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg )
+ CmmStore (cmmRegOffW spReg offset)
+ (CmmReg (CmmGlobal reg))
+
+ stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
+ stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
+ jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
+-}
+
+-----------------------------------------
+thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode ()
+thunkCode cl_info cc srt node body
+ = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
+
+ ; tickyEnterThunk cl_info
+ ; ldvEnterClosure cl_info -- NB: Node always points when profiling
+ ; granThunk node_points
+
+ -- Heap overflow check
+ ; entryHeapCheck node [] srt $ do
+ { -- Overwrite with black hole if necessary
+ -- but *after* the heap-overflow check
+ whenC (blackHoleOnEntry cl_info && node_points)
+ (blackHoleIt cl_info)
+
+ -- Push update frame
+ ; setupUpdate cl_info node
+
+ -- We only enter cc after setting up update so
+ -- that cc of enclosing scope will be recorded
+ -- in update frame CAF/DICT functions will be
+ -- subsumed by this enclosing cc
+ ; enterCostCentre cl_info cc body
+
+ ; cgExpr body } }
+
+
+------------------------------------------------------------------------
+-- Update and black-hole wrappers
+------------------------------------------------------------------------
+
+blackHoleIt :: ClosureInfo -> FCode ()
+-- Only called for closures with no args
+-- Node points to the closure
+blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
+
+emitBlackHoleCode :: Bool -> FCode ()
+emitBlackHoleCode is_single_entry
+ | eager_blackholing = do
+ tickyBlackHole (not is_single_entry)
+ emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
+ | otherwise =
+ nopC
+ where
+ bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
+ | otherwise = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
+
+ -- If we wanted to do eager blackholing with slop filling,
+ -- we'd need to do it at the *end* of a basic block, otherwise
+ -- we overwrite the free variables in the thunk that we still
+ -- need. We have a patch for this from Andy Cheadle, but not
+ -- incorporated yet. --SDM [6/2004]
+ --
+ -- Profiling needs slop filling (to support LDV profiling), so
+ -- currently eager blackholing doesn't work with profiling.
+ --
+ -- Previously, eager blackholing was enabled when ticky-ticky
+ -- was on. But it didn't work, and it wasn't strictly necessary
+ -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
+ -- is unconditionally disabled. -- krc 1/2007
+
+ eager_blackholing = False
+
+setupUpdate :: ClosureInfo -> LocalReg -> FCode ()
+ -- Nota Bene: this function does not change Node (even if it's a CAF),
+ -- so that the cost centre in the original closure can still be
+ -- extracted by a subsequent enterCostCentre
+setupUpdate closure_info node
+ | closureReEntrant closure_info
+ = return ()
+
+ | not (isStaticClosure closure_info)
+ = if closureUpdReqd closure_info
+ then do { tickyPushUpdateFrame; pushUpdateFrame node }
+ else tickyUpdateFrameOmitted
+
+ | otherwise -- A static closure
+ = do { tickyUpdateBhCaf closure_info
+
+ ; if closureUpdReqd closure_info
+ then do -- Blackhole the (updatable) CAF:
+ { upd_closure <- link_caf closure_info True
+ ; pushUpdateFrame upd_closure }
+ else tickyUpdateFrameOmitted
+ }
+
+pushUpdateFrame :: LocalReg -> FCode ()
+pushUpdateFrame cl_reg
+ = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel)
+ [CmmReg (CmmLocal cl_reg)])
+
+-----------------------------------------------------------------------------
+-- Entering a CAF
+--
+-- When a CAF is first entered, it creates a black hole in the heap,
+-- and updates itself with an indirection to this new black hole.
+--
+-- We update the CAF with an indirection to a newly-allocated black
+-- hole in the heap. We also set the blocking queue on the newly
+-- allocated black hole to be empty.
+--
+-- Why do we make a black hole in the heap when we enter a CAF?
+--
+-- - for a generational garbage collector, which needs a fast
+-- test for whether an updatee is in an old generation or not
+--
+-- - for the parallel system, which can implement updates more
+-- easily if the updatee is always in the heap. (allegedly).
+--
+-- When debugging, we maintain a separate CAF list so we can tell when
+-- a CAF has been garbage collected.
+
+-- newCAF must be called before the itbl ptr is overwritten, since
+-- newCAF records the old itbl ptr in order to do CAF reverting
+-- (which Hugs needs to do in order that combined mode works right.)
+--
+
+-- ToDo [Feb 04] This entire link_caf nonsense could all be moved
+-- into the "newCAF" RTS procedure, which we call anyway, including
+-- the allocation of the black-hole indirection closure.
+-- That way, code size would fall, the CAF-handling code would
+-- be closer together, and the compiler wouldn't need to know
+-- about off_indirectee etc.
+
+link_caf :: ClosureInfo
+ -> Bool -- True <=> updatable, False <=> single-entry
+ -> FCode LocalReg -- Returns amode for closure to be updated
+-- To update a CAF we must allocate a black hole, link the CAF onto the
+-- CAF list, then update the CAF to point to the fresh black hole.
+-- This function returns the address of the black hole, so it can be
+-- updated with the new value when available. The reason for all of this
+-- is that we only want to update dynamic heap objects, not static ones,
+-- so that generational GC is easier.
+link_caf cl_info is_upd = do
+ { -- Alloc black hole specifying CC_HDR(Node) as the cost centre
+ ; let use_cc = costCentreFrom (CmmReg nodeReg)
+ blame_cc = use_cc
+ ; hp_rel <- allocDynClosure bh_cl_info use_cc blame_cc []
+
+ -- Call the RTS function newCAF to add the CAF to the CafList
+ -- so that the garbage collector can find them
+ -- This must be done *before* the info table pointer is overwritten,
+ -- because the old info table ptr is needed for reversion
+ ; emitRtsCallWithVols (sLit "newCAF") [(CmmReg nodeReg,AddrHint)] [node] False
+ -- node is live, so save it.
+
+ -- Overwrite the closure with a (static) indirection
+ -- to the newly-allocated black hole
+ ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
+ mkStore (CmmReg nodeReg) ind_static_info)
+
+ ; return hp_rel }
+ where
+ bh_cl_info :: ClosureInfo
+ bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
+ | otherwise = seCafBlackHoleClosureInfo cl_info
+
+ ind_static_info :: CmmExpr
+ ind_static_info = mkLblExpr mkIndStaticInfoLabel
+
+ off_indirectee :: WordOff
+ off_indirectee = fixedHdrSize + oFFSET_StgInd_indirectee*wORD_SIZE
+
+
+------------------------------------------------------------------------
+-- Profiling
+------------------------------------------------------------------------
+
+-- For "global" data constructors the description is simply occurrence
+-- name of the data constructor itself. Otherwise it is determined by
+-- @closureDescription@ from the let binding information.
+
+closureDescription :: Module -- Module
+ -> Name -- Id of closure binding
+ -> String
+ -- Not called for StgRhsCon which have global info tables built in
+ -- CgConTbls.lhs with a description generated from the data constructor
+closureDescription mod_name name
+ = showSDocDump (char '<' <>
+ (if isExternalName name
+ then ppr name -- ppr will include the module name prefix
+ else pprModule mod_name <> char '.' <> ppr name) <>
+ char '>')
+ -- showSDocDump, because we want to see the unique on the Name.
+
projects / ghc-hetmet.git / blobdiff