%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.62 2003/11/17 14:23:31 simonmar Exp $
+% $Id: CgClosure.lhs,v 1.63 2004/08/13 13:05:54 simonmar Exp $
%
\section[CgClosure]{Code generation for closures}
module CgClosure ( cgTopRhsClosure,
cgStdRhsClosure,
cgRhsClosure,
+ emitBlackHoleCode,
) where
#include "HsVersions.h"
import CgMonad
import CgBindery
-import CgUpdate ( pushUpdateFrame )
import CgHeapery
-import CgStackery
-import CgUsages
+import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp,
+ setRealAndVirtualSp )
+import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre,
+ costCentreFrom )
+import CgTicky
+import CgParallel ( granYield, granFetchAndReschedule )
+import CgInfoTbls ( emitClosureCodeAndInfoTable, getSRTInfo )
+import CgCallConv ( assignCallRegs, mkArgDescr )
+import CgUtils ( emitDataLits, addIdReps, cmmRegOffW,
+ emitRtsCallWithVols )
import ClosureInfo -- lots and lots of stuff
-
-import AbsCUtils ( getAmodeRep, mkAbstractCs )
-import AbsCSyn
-import CLabel
-
+import SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff,
+ idCgRep )
+import MachOp ( MachHint(..) )
+import Cmm
+import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
+ mkLblExpr )
+import CLabel ( mkRtsDataLabel, mkClosureLabel, mkRednCountsLabel,
+ mkSlowEntryLabel, mkIndStaticInfoLabel )
import StgSyn
-import CmdLineOpts ( opt_GranMacros, opt_SccProfilingOn, opt_DoTickyProfiling )
+import CmdLineOpts ( opt_DoTickyProfiling )
import CostCentre
-import Id ( Id, idName, idType, idPrimRep )
-import Name ( Name, isInternalName )
+import Id ( Id, idName, idType )
+import Name ( Name )
import Module ( Module, pprModule )
import ListSetOps ( minusList )
-import PrimRep ( PrimRep(..), getPrimRepSize )
-import Util ( isIn, splitAtList )
-import CmdLineOpts ( opt_SccProfilingOn )
+import Util ( isIn, mapAccumL, zipWithEqual )
+import BasicTypes ( TopLevelFlag(..) )
+import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE )
import Outputable
import FastString
-
-import Name ( nameOccName )
-import OccName ( occNameFS )
-
--- Turgid imports for showTypeCategory
-import PrelNames
-import TcType ( Type, isDictTy, tcSplitTyConApp_maybe, tcSplitFunTy_maybe )
-import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon, maybeTyConSingleCon )
-import Maybe
\end{code}
%********************************************************
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
-> SRT
+ -> UpdateFlag
-> [Id] -- Args
-> StgExpr
- -> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info srt args body lf_info
- =
- let
- name = idName id
- in
- -- LAY OUT THE OBJECT
- getSRTInfo name srt `thenFC` \ srt_info ->
- moduleName `thenFC` \ mod_name ->
- let
- name = idName id
- descr = closureDescription mod_name name
- closure_info = layOutStaticNoFVClosure id lf_info srt_info descr
+cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+ { -- LAY OUT THE OBJECT
+ let name = idName id
+ ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
+ ; srt_info <- getSRTInfo name srt
+ ; mod_name <- moduleName
+ ; let descr = closureDescription mod_name name
+ closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
closure_label = mkClosureLabel name
- cg_id_info = stableAmodeIdInfo id (CLbl closure_label PtrRep) lf_info
- in
-
- -- BUILD THE OBJECT (IF NECESSARY)
- (
- ({- if staticClosureRequired name binder_info lf_info
- then -}
- absC (mkStaticClosure closure_label closure_info ccs [] True)
- {- else
- nopC -}
- )
- `thenC`
-
- -- GENERATE THE INFO TABLE (IF NECESSARY)
- forkClosureBody (closureCodeBody binder_info closure_info
- ccs args body)
+ cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
+ closure_rep = mkStaticClosureFields closure_info ccs True []
- ) `thenC`
-
- returnFC (id, cg_id_info)
+ -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
+ ; emitDataLits closure_label closure_rep
+ ; forkClosureBody (closureCodeBody binder_info closure_info
+ ccs args body)
+ ; returnFC (id, cg_id_info) }
\end{code}
%********************************************************
-> [StgArg] -- payload
-> FCode (Id, CgIdInfo)
-cgStdRhsClosure binder cc binder_info fvs args body lf_info payload
- -- AHA! A STANDARD-FORM THUNK
- = (
- -- LAY OUT THE OBJECT
- getArgAmodes payload `thenFC` \ amodes ->
- moduleName `thenFC` \ mod_name ->
- let
- descr = closureDescription mod_name (idName binder)
-
- (closure_info, amodes_w_offsets)
- = layOutDynClosure binder getAmodeRep amodes lf_info NoC_SRT descr
- -- No SRT for a standard-form closure
-
- (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
- in
+cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
+ = do -- AHA! A STANDARD-FORM THUNK
+ { -- LAY OUT THE OBJECT
+ amodes <- getArgAmodes payload
+ ; mod_name <- moduleName
+ ; let (tot_wds, ptr_wds, amodes_w_offsets) = mkVirtHeapOffsets amodes
+
+ 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 args body
-- BUILD THE OBJECT
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- )
- `thenFC` \ heap_offset ->
+ ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-- RETURN
- returnFC (binder, heapIdInfo binder heap_offset lf_info)
+ ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
\end{code}
Here's the general case.
-> StgBinderInfo
-> SRT
-> [Id] -- Free vars
+ -> UpdateFlag
-> [Id] -- Args
-> StgExpr
- -> LambdaFormInfo
-> FCode (Id, CgIdInfo)
-cgRhsClosure binder cc binder_info srt fvs args body lf_info
- = (
- -- LAY OUT THE OBJECT
- --
+cgRhsClosure bndr cc bndr_info srt fvs upd_flag 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
-- stored in the closure itself, so it will make sure that
-- Node points to it...
let
- is_elem = isIn "cgRhsClosure"
-
- binder_is_a_fv = binder `is_elem` fvs
- reduced_fvs = if binder_is_a_fv
- then fvs `minusList` [binder]
- else fvs
-
- name = idName binder
- in
-
- mapFCs getCAddrModeAndInfo reduced_fvs `thenFC` \ fvs_w_amodes_and_info ->
- getSRTInfo name srt `thenFC` \ srt_info ->
- moduleName `thenFC` \ mod_name ->
- let
- descr = closureDescription mod_name (idName binder)
-
- closure_info :: ClosureInfo
- bind_details :: [((Id, CAddrMode, LambdaFormInfo), VirtualHeapOffset)]
-
- (closure_info, bind_details)
- = layOutDynClosure binder get_kind
- fvs_w_amodes_and_info lf_info srt_info descr
-
- bind_fv ((id, _, lf_info), offset) = bindNewToNode id offset lf_info
-
- amodes_w_offsets = [(amode,offset) | ((_,amode,_), offset) <- bind_details]
-
- get_kind (id, _, _) = idPrimRep id
- in
+ name = idName bndr
+ is_elem = isIn "cgRhsClosure"
+ bndr_is_a_fv = bndr `is_elem` fvs
+ reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr]
+ | otherwise = fvs
+
+ ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
+ ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
+ ; srt_info <- getSRTInfo name srt
+ ; mod_name <- moduleName
+ ; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
+ (tot_wds, ptr_wds, bind_details) = mkVirtHeapOffsets (map add_rep fv_infos)
+ add_rep info = (cgIdInfoArgRep info, info)
+
+ descr = closureDescription mod_name name
+ closure_info = mkClosureInfo False -- Not static
+ bndr lf_info tot_wds ptr_wds
+ srt_info descr
-- BUILD ITS INFO TABLE AND CODE
- forkClosureBody (
- -- Bind the fvs
- mapCs bind_fv bind_details `thenC`
+ ; forkClosureBody (do
+ { -- Bind the fvs
+ let bind_fv (info, offset)
+ = bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
+ ; mapCs bind_fv bind_details
-- Bind the binder itself, if it is a free var
- (if binder_is_a_fv then
- bindNewToReg binder node lf_info
- else
- nopC) `thenC`
-
+ ; whenC bndr_is_a_fv (bindNewToReg bndr nodeReg lf_info)
+
-- Compile the body
- closureCodeBody binder_info closure_info cc args body
- ) `thenC`
+ ; closureCodeBody bndr_info closure_info cc args body })
-- BUILD THE OBJECT
- let
- (use_cc, blame_cc) = chooseDynCostCentres cc args fvs body
- in
- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
- ) `thenFC` \ heap_offset ->
+ ; let
+ to_amode (info, offset) = do { amode <- idInfoToAmode info
+ ; return (amode, offset) }
+ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
+ ; amodes_w_offsets <- mapFCs to_amode bind_details
+ ; heap_offset <- allocDynClosure closure_info use_cc blame_cc amodes_w_offsets
-- RETURN
- returnFC (binder, heapIdInfo binder heap_offset lf_info)
+ ; returnFC (bndr, heapIdInfo bndr heap_offset lf_info) }
+
+
+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) }
\end{code}
+
%************************************************************************
%* *
\subsection[code-for-closures]{The code for closures}
There are two main cases for the code for closures. If there are {\em
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!
\begin{code}
-closureCodeBody binder_info closure_info cc [] body
- = -- thunks cannot have a primitive type!
- getAbsC body_code `thenFC` \ body_absC ->
-
- absC (CClosureInfoAndCode closure_info body_absC)
- where
- is_box = case body of { StgApp fun [] -> True; _ -> False }
-
- ticky_ent_lit = if (isStaticClosure closure_info)
- then FSLIT("TICK_ENT_STATIC_THK")
- else FSLIT("TICK_ENT_DYN_THK")
-
- body_code = profCtrC ticky_ent_lit [] `thenC`
- -- node always points when profiling, so this is ok:
- ldvEnter `thenC`
- thunkWrapper closure_info (
- -- 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
- enterCostCentreCode closure_info cc IsThunk is_box `thenC`
- cgExpr body
- )
-
+closureCodeBody binder_info cl_info cc [] body = do
+ { body_absC <- getCgStmts $ do
+ { tickyEnterThunk cl_info
+ ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
+ ; thunkWrapper cl_info $ do
+ -- 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 }
+ }
+
+ ; emitClosureCodeAndInfoTable cl_info [] body_absC }
\end{code}
If there is /at least one argument/, then this closure is in
Node points to closure is available. -- HWL
\begin{code}
-closureCodeBody binder_info closure_info cc all_args body
- = let arg_reps = map idPrimRep all_args in
-
- getEntryConvention name lf_info arg_reps `thenFC` \ entry_conv ->
-
- let
- -- Arg mapping for the entry point; as many args as poss in
- -- registers; the rest on the stack
- -- arg_regs are the registers used for arg passing
- -- stk_args are the args which are passed on the stack
- --
- -- Args passed on the stack are not tagged.
- --
- arg_regs = case entry_conv of
- DirectEntry lbl arity regs -> regs
- _ -> panic "closureCodeBody"
- in
-
- -- 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
- --
- (case closureFunInfo closure_info of
- Just (_, ArgGen slow_lbl liveness) ->
- absC (maybeLargeBitmap liveness) `thenC`
- absC (mkSlowEntryCode name slow_lbl arg_regs arg_reps) `thenC`
- returnFC (mkRegSaveCode arg_regs arg_reps)
-
- other -> returnFC AbsCNop
- )
- `thenFC` \ reg_save_code ->
-
- -- get the current virtual Sp (it might not be zero, eg. if we're
- -- compiling a let-no-escape).
- getVirtSp `thenFC` \vSp ->
-
- let
- (reg_args, stk_args) = splitAtList arg_regs all_args
-
- (sp_stk_args, stk_offsets)
- = mkVirtStkOffsets vSp idPrimRep stk_args
-
- entry_code = do
- mod_name <- moduleName
- profCtrC FSLIT("TICK_CTR") [
- CLbl ticky_ctr_label DataPtrRep,
- mkCString (mkFastString (ppr_for_ticky_name mod_name name)),
- mkIntCLit stg_arity, -- total # of args
- mkIntCLit sp_stk_args, -- # passed on stk
- mkCString (mkFastString (map (showTypeCategory . idType) all_args))
- ]
- let prof =
- profCtrC ticky_ent_lit [
- CLbl ticky_ctr_label DataPtrRep
- ]
-
- -- Bind args to regs/stack as appropriate, and
- -- record expected position of sps.
- bindArgsToRegs reg_args arg_regs
- mapCs bindNewToStack stk_offsets
- setRealAndVirtualSp sp_stk_args
-
- -- Enter the closures cc, if required
- enterCostCentreCode closure_info cc IsFunction False
-
- -- Do the business
- funWrapper closure_info arg_regs reg_save_code
- (prof >> cgExpr body)
- in
-
- setTickyCtrLabel ticky_ctr_label (
-
- forkAbsC entry_code `thenFC` \ entry_abs_c ->
- moduleName `thenFC` \ mod_name ->
-
- -- Now construct the info table
- absC (CClosureInfoAndCode closure_info entry_abs_c)
- )
- where
- ticky_ctr_label = mkRednCountsLabel name
-
- ticky_ent_lit =
- if (isStaticClosure closure_info)
- then FSLIT("TICK_ENT_STATIC_FUN_DIRECT")
- else FSLIT("TICK_ENT_DYN_FUN_DIRECT")
-
- stg_arity = length all_args
- lf_info = closureLFInfo closure_info
-
- -- Manufacture labels
- name = closureName closure_info
-
-
--- When printing the name of a thing in a ticky file, we want to
--- give the module name even for *local* things. We print
--- just "x (M)" rather that "M.x" to distinguish them from the global kind.
-ppr_for_ticky_name mod_name name
- | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
- | otherwise = showSDocDebug (ppr name)
+closureCodeBody binder_info cl_info cc args body = do
+ { -- Get the current virtual Sp (it might not be zero,
+ -- eg. if we're compiling a let-no-escape).
+ vSp <- getVirtSp
+ ; let (reg_args, other_args) = assignCallRegs (addIdReps args)
+ (sp_top, stk_args) = mkVirtStkOffsets vSp other_args
+
+ -- Allocate the global ticky counter
+ ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
+ ; emitTickyCounter cl_info args sp_top
+
+ -- ...and establish the ticky-counter
+ -- label for this block
+ ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+ -- Emit the slow-entry code
+ { reg_save_code <- mkSlowEntryCode cl_info reg_args
+
+ -- Emit the main entry code
+ ; blks <- forkProc $
+ mkFunEntryCode cl_info cc reg_args stk_args
+ sp_top reg_save_code body
+ ; emitClosureCodeAndInfoTable cl_info [] blks
+ }}
+
+
+
+mkFunEntryCode :: ClosureInfo
+ -> CostCentreStack
+ -> [(Id,GlobalReg)] -- Args in regs
+ -> [(Id,VirtualSpOffset)] -- Args on stack
+ -> VirtualSpOffset -- Last allocated word on stack
+ -> CmmStmts -- Register-save code in case of GC
+ -> StgExpr
+ -> Code
+-- The main entry code for the closure
+mkFunEntryCode cl_info cc reg_args stk_args sp_top reg_save_code body = do
+ { -- Bind args to regs/stack as appropriate,
+ -- and record expected position of sps
+ ; bindArgsToRegs reg_args
+ ; bindArgsToStack stk_args
+ ; setRealAndVirtualSp sp_top
+
+ -- Enter the cost-centre, if required
+ -- ToDo: It's not clear why this is outside the funWrapper,
+ -- but the tickyEnterFun is inside. Perhaps we can put
+ -- them together?
+ ; enterCostCentre cl_info cc body
+
+ -- Do the business
+ ; funWrapper cl_info reg_args reg_save_code $ do
+ { tickyEnterFun cl_info
+ ; cgExpr body }
+ }
\end{code}
The "slow entry" code for a function. This entry point takes its
(b) returning from a heap-check failure
\begin{code}
-mkSlowEntryCode :: Name -> CLabel -> [MagicId] -> [PrimRep] -> AbstractC
-mkSlowEntryCode name lbl regs reps
- = CCodeBlock lbl (
- mkAbstractCs [assts, stk_adj, jump]
- )
+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
- stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
-
- assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
- mk_asst rep reg offset = CAssign (CReg reg) (CVal (spRel 0 offset) rep)
-
- stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 stk_final_offset))
- stk_final_offset = head (drop (length regs) stk_offsets)
-
- jump = CJump (CLbl (mkEntryLabel name) CodePtrRep)
-
-mkRegSaveCode :: [MagicId] -> [PrimRep] -> AbstractC
-mkRegSaveCode regs reps
- = mkAbstractCs [stk_adj, assts]
- where
- stk_adj = CAssign (CReg Sp) (CAddr (spRel 0 (negate stk_final_offset)))
-
- stk_final_offset = head (drop (length regs) stk_offsets)
- stk_offsets = scanl (\off rep -> off - getPrimRepSize rep) 0 reps
-
- assts = mkAbstractCs (zipWith3 mk_asst reps regs stk_offsets)
- mk_asst rep reg offset = CAssign (CVal (spRel 0 offset) rep) (CReg reg)
+ 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 == globalRegRep 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 (enterIdLabel name)) []
\end{code}
-For lexically scoped profiling we have to load the cost centre from
-the closure entered, if the costs are not supposed to be inherited.
-This is done immediately on entering the fast entry point.
-
-Load current cost centre from closure, if not inherited.
-Node is guaranteed to point to it, if profiling and not inherited.
-
-\begin{code}
-data IsThunk = IsThunk | IsFunction -- Bool-like, local
--- #ifdef DEBUG
- deriving Eq
--- #endif
-
-enterCostCentreCode
- :: ClosureInfo -> CostCentreStack
- -> IsThunk
- -> Bool -- is_box: this closure is a special box introduced by SCCfinal
- -> Code
-
-enterCostCentreCode closure_info ccs is_thunk is_box
- = if not opt_SccProfilingOn then
- nopC
- else
- ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
-
- if isSubsumedCCS ccs then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsFunction)
- costCentresC FSLIT("ENTER_CCS_FSUB") []
-
- else if isDerivedFromCurrentCCS ccs then
- if re_entrant && not is_box
- then costCentresC FSLIT("ENTER_CCS_FCL") [CReg node]
- else costCentresC FSLIT("ENTER_CCS_TCL") [CReg node]
-
- else if isCafCCS ccs then
- ASSERT(isToplevClosure closure_info)
- ASSERT(is_thunk == IsThunk)
- -- might be a PAP, in which case we want to subsume costs
- if re_entrant
- then costCentresC FSLIT("ENTER_CCS_FSUB") []
- else costCentresC FSLIT("ENTER_CCS_CAF") c_ccs
-
- else panic "enterCostCentreCode"
-
- where
- c_ccs = [mkCCostCentreStack ccs]
- re_entrant = closureReEntrant closure_info
-\end{code}
%************************************************************************
%* *
\begin{code}
thunkWrapper:: ClosureInfo -> Code -> Code
-thunkWrapper closure_info thunk_code
- = -- Stack and heap overflow checks
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
+thunkWrapper closure_info thunk_code = do
+ { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-- (we prefer fetchAndReschedule-style context switches to yield ones)
- (if opt_GranMacros
- then if node_points
- then fetchAndReschedule [] node_points
- else yield [] node_points
- else absC AbsCNop) `thenC`
-
- let closure_lbl
- | node_points = Nothing
- | otherwise = Just (closureLabelFromCI closure_info)
- in
-
- -- stack and/or heap checks
- thunkChecks closure_lbl (
-
- -- Overwrite with black hole if necessary
- blackHoleIt closure_info node_points `thenC`
-
- setupUpdate closure_info ( -- setupUpdate *encloses* the rest
-
- -- Finally, do the business
- thunk_code
- ))
+ ; if node_points
+ then granFetchAndReschedule [] node_points
+ else granYield [] node_points
+
+ -- Stack and/or heap checks
+ ; thunkEntryChecks closure_info $ do
+ { -- Overwrite with black hole if necessary
+ whenC (blackHoleOnEntry closure_info && node_points)
+ (blackHoleIt closure_info)
+ ; setupUpdate closure_info thunk_code }
+ -- setupUpdate *encloses* the thunk_code
+ }
funWrapper :: ClosureInfo -- Closure whose code body this is
- -> [MagicId] -- List of argument registers (if any)
- -> AbstractC -- reg saves for the heap check failure
+ -> [(Id,GlobalReg)] -- List of argument registers (if any)
+ -> CmmStmts -- reg saves for the heap check failure
-> Code -- Body of function being compiled
-> Code
-funWrapper closure_info arg_regs reg_save_code fun_body
- = -- Stack overflow check
- nodeMustPointToIt (closureLFInfo closure_info) `thenFC` \ node_points ->
-
- -- enter for Ldv profiling
- (if node_points then ldvEnter else nopC) `thenC`
+funWrapper closure_info arg_regs reg_save_code fun_body = do
+ { let node_points = nodeMustPointToIt (closureLFInfo closure_info)
- (if opt_GranMacros
- then yield arg_regs node_points
- else absC AbsCNop) `thenC`
+ -- Enter for Ldv profiling
+ ; whenC node_points (ldvEnter (CmmReg nodeReg))
- let closure_lbl
- | node_points = Nothing
- | otherwise = Just (closureLabelFromCI closure_info)
- in
+ -- GranSim yeild poin
+ ; granYield arg_regs node_points
- -- heap and/or stack checks
- funEntryChecks closure_lbl reg_save_code (
-
- -- Finally, do the business
- fun_body
- )
+ -- Heap and/or stack checks wrap the function body
+ ; funEntryChecks closure_info reg_save_code
+ fun_body
+ }
\end{code}
\begin{code}
-blackHoleIt :: ClosureInfo -> Bool -> Code -- Only called for closures with no args
-
-blackHoleIt closure_info node_points
- = if blackHoleOnEntry closure_info && node_points
- then
- let
- info_label = infoTableLabelFromCI closure_info
- args = [ CLbl info_label DataPtrRep ]
- in
- absC (if closureSingleEntry(closure_info) then
- CMacroStmt UPD_BH_SINGLE_ENTRY args
- else
- CMacroStmt UPD_BH_UPDATABLE args)
- else
+blackHoleIt :: ClosureInfo -> Code
+-- Only called for closures with no args
+-- Node points to the closure
+blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
+
+emitBlackHoleCode :: Bool -> Code
+emitBlackHoleCode is_single_entry
+ | eager_blackholing = do
+ tickyBlackHole (not is_single_entry)
+ stmtC (CmmStore (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.
+ --
+ -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
+ -- single-entry thunks.
+ eager_blackholing
+ | opt_DoTickyProfiling = True
+ | otherwise = False
+
\end{code}
\begin{code}
setupUpdate :: ClosureInfo -> Code -> Code -- Only called for closures with no args
-- 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 ENTER_CC_TCL
-
--- I've tidied up the code for this function, but it should still do the same as
--- it did before (modulo ticky stuff). KSW 1999-04.
+ -- extracted by a subsequent enterCostCentre
setupUpdate closure_info code
- = if closureReEntrant closure_info
- then
- code
- else
- case (closureUpdReqd closure_info, isStaticClosure closure_info) of
- (False,False) -> profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
- (False,True ) -> (if opt_DoTickyProfiling
- then
- -- blackhole the SE CAF
- link_caf seCafBlackHoleClosureInfo `thenFC` \ _ -> nopC
- else
- nopC) `thenC`
- profCtrC FSLIT("TICK_UPD_CAF_BH_SINGLE_ENTRY") [mkCString cl_name] `thenC`
- profCtrC FSLIT("TICK_UPDF_OMITTED") [] `thenC`
- code
- (True ,False) -> pushUpdateFrame (CReg node) code
- (True ,True ) -> -- blackhole the (updatable) CAF:
- link_caf cafBlackHoleClosureInfo `thenFC` \ update_closure ->
- profCtrC FSLIT("TICK_UPD_CAF_BH_UPDATABLE") [mkCString cl_name] `thenC`
- pushUpdateFrame update_closure code
- where
- cl_name :: FastString
- cl_name = (occNameFS . nameOccName . closureName) closure_info
-
- link_caf :: (ClosureInfo -> ClosureInfo) -- function yielding BH closure_info
- -> FCode CAddrMode -- Returns amode for closure to be updated
- link_caf bhCI
- = -- 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.
-
- -- Alloc black hole specifying CC_HDR(Node) as the cost centre
- let
- use_cc = CMacroExpr PtrRep CCS_HDR [nodeReg]
- blame_cc = use_cc
- in
- allocDynClosure (bhCI closure_info) use_cc blame_cc [] `thenFC` \ heap_offset ->
- getHpRelOffset heap_offset `thenFC` \ hp_rel ->
- let amode = CAddr hp_rel
- in
- absC (CMacroStmt UPD_CAF [CReg node, amode]) `thenC`
- returnFC amode
+ | closureReEntrant closure_info
+ = code
+
+ | not (isStaticClosure closure_info)
+ = if closureUpdReqd closure_info
+ then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
+ else do { tickyUpdateFrameOmitted; code }
+
+ | 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 code }
+ else do
+ { -- No update reqd, you'd think we don't need to
+ -- black-hole it. But when ticky-ticky is on, we
+ -- black-hole it regardless, to catch errors in which
+ -- an allegedly single-entry closure is entered twice
+ --
+ -- We discard the pointer returned by link_caf, because
+ -- we don't push an update frame
+ whenC opt_DoTickyProfiling -- Blackhole even a SE CAF
+ (link_caf closure_info False >> nopC)
+ ; tickyUpdateFrameOmitted
+ ; code }
+ }
+
+
+-----------------------------------------------------------------------------
+-- 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 CmmExpr -- 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_offset <- allocDynClosure bh_cl_info use_cc blame_cc []
+ ; hp_rel <- getHpRelOffset hp_offset
+
+ -- 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,PtrHint)] [node]
+ -- node is live, so save it.
+
+ -- Overwrite the closure with a (static) indirection
+ -- to the newly-allocated black hole
+ ; stmtsC [ CmmStore (cmmRegOffW nodeReg off_indirectee) hp_rel
+ , CmmStore (CmmReg nodeReg) ind_static_info ]
+
+ ; returnFC 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
\end{code}
+
%************************************************************************
%* *
\subsection[CgClosure-Description]{Profiling Closure Description.}
%************************************************************************
For "global" data constructors the description is simply occurrence
-name of the data constructor itself (see \ref{CgConTbls-info-tables}).
-
-Otherwise it is determind by @closureDescription@ from the let
-binding information.
+name of the data constructor itself. Otherwise it is determined by
+@closureDescription@ from the let binding information.
\begin{code}
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
- = showSDoc (
- hcat [char '<',
- pprModule mod_name,
- char '.',
- ppr name,
- char '>'])
+ = showSDoc (hcat [char '<', pprModule mod_name,
+ char '.', ppr name, char '>'])
\end{code}
-\begin{code}
-chooseDynCostCentres ccs args fvs body
- = let
- use_cc -- cost-centre we record in the object
- = if currentOrSubsumedCCS ccs
- then CReg CurCostCentre
- else mkCCostCentreStack ccs
-
- blame_cc -- cost-centre on whom we blame the allocation
- = case (args, fvs, body) of
- ([], _, StgApp fun [{-no args-}])
- -> mkCCostCentreStack overheadCCS
- _ -> use_cc
-
- -- if it's an utterly trivial RHS, then it must be
- -- one introduced by boxHigherOrderArgs for profiling,
- -- so we charge it to "OVERHEAD".
-
- -- This looks like a HACK to me --SDM
- in
- (use_cc, blame_cc)
-\end{code}
-
-
-\begin{code}
-showTypeCategory :: Type -> Char
- {-
- {C,I,F,D} char, int, float, double
- T tuple
- S other single-constructor type
- {c,i,f,d} unboxed ditto
- t *unpacked* tuple
- s *unpacked" single-cons...
-
- v void#
- a primitive array
-
- E enumeration type
- + dictionary, unless it's a ...
- L List
- > function
- M other (multi-constructor) data-con type
- . other type
- - reserved for others to mark as "uninteresting"
- -}
-showTypeCategory ty
- = if isDictTy ty
- then '+'
- else
- case tcSplitTyConApp_maybe ty of
- Nothing -> if isJust (tcSplitFunTy_maybe ty)
- then '>'
- else '.'
-
- Just (tycon, _) ->
- let utc = getUnique tycon in
- if utc == charDataConKey then 'C'
- else if utc == intDataConKey then 'I'
- else if utc == floatDataConKey then 'F'
- else if utc == doubleDataConKey then 'D'
- else if utc == smallIntegerDataConKey ||
- utc == largeIntegerDataConKey then 'J'
- else if utc == charPrimTyConKey then 'c'
- else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
- || utc == addrPrimTyConKey) then 'i'
- else if utc == floatPrimTyConKey then 'f'
- else if utc == doublePrimTyConKey then 'd'
- else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
- else if isEnumerationTyCon tycon then 'E'
- else if isTupleTyCon tycon then 'T'
- else if isJust (maybeTyConSingleCon tycon) then 'S'
- else if utc == listTyConKey then 'L'
- else 'M' -- oh, well...
-\end{code}
projects / ghc-hetmet.git / blobdiff