%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgClosure.lhs,v 1.72 2005/05/18 12:06:51 simonmar Exp $
-%
\section[CgClosure]{Code generation for closures}
This module provides the support code for @StgToAbstractC@ to deal
import CgMonad
import CgBindery
import CgHeapery
-import CgStackery ( mkVirtStkOffsets, pushUpdateFrame, getVirtSp,
- setRealAndVirtualSp )
-import CgProf ( chooseDynCostCentres, ldvEnter, enterCostCentre,
- costCentreFrom )
+import CgStackery
+import CgProf
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 SMRep ( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff,
- idCgRep )
-import MachOp ( MachHint(..) )
+import CgParallel
+import CgInfoTbls
+import CgCallConv
+import CgUtils
+import ClosureInfo
+import SMRep
import Cmm
-import CmmUtils ( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
- mkLblExpr )
+import CmmUtils
import CLabel
import StgSyn
-import StaticFlags ( opt_DoTickyProfiling )
import CostCentre
-import Id ( Id, idName, idType )
-import Name ( Name, isExternalName )
-import Module ( Module, pprModule )
-import ListSetOps ( minusList )
-import Util ( isIn, mapAccumL, zipWithEqual )
-import BasicTypes ( TopLevelFlag(..) )
-import Constants ( oFFSET_StgInd_indirectee, wORD_SIZE )
+import Id
+import Name
+import Module
+import ListSetOps
+import Util
+import BasicTypes
+import StaticFlags
+import DynFlags
+import Constants
import Outputable
import FastString
+
+import Data.List
\end{code}
%********************************************************
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+cgTopRhsClosure id ccs binder_info 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
+ ; srt_info <- getSRTInfo
+ ; 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
+ closure_label = mkLocalClosureLabel name $ idCafInfo id
cg_id_info = stableIdInfo id (mkLblExpr closure_label) lf_info
closure_rep = mkStaticClosureFields closure_info ccs True []
-> [StgArg] -- payload
-> FCode (Id, CgIdInfo)
-cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
+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
+ ; mod_name <- getModuleName
; let (tot_wds, ptr_wds, amodes_w_offsets)
= mkVirtHeapOffsets (isLFThunk lf_info) amodes
cgRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT
-> [Id] -- Free vars
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (Id, CgIdInfo)
-cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
+cgRhsClosure bndr cc bndr_info 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.
-- Node points to it...
let
name = idName bndr
- is_elem = isIn "cgRhsClosure"
- bndr_is_a_fv = bndr `is_elem` fvs
+ bndr_is_a_fv = bndr `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
+ ; srt_info <- getSRTInfo
+ ; mod_name <- getModuleName
; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
(tot_wds, ptr_wds, bind_details)
= mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
-- BUILD ITS INFO TABLE AND CODE
; forkClosureBody (do
{ -- Bind the fvs
- let bind_fv (info, offset)
+ let
+ -- A function closure pointer may be tagged, so we
+ -- must take it into account when accessing the free variables.
+ mbtag = tagForArity (length args)
+ bind_fv (info, offset)
+ | Just tag <- mbtag
+ = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
+ | otherwise
= bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
; mapCs bind_fv bind_details
NB: Thunks cannot have a primitive type!
\begin{code}
-closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
+closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do
{ body_absC <- getCgStmts $ do
{ tickyEnterThunk cl_info
- ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
+ ; ldvEnterClosure cl_info -- 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
+ ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body]
; cgExpr body }
}
Node points to closure is available. -- HWL
\begin{code}
-closureCodeBody binder_info cl_info cc args body
+closureCodeBody _binder_info cl_info cc args body
= ASSERT( length args > 0 )
do { -- Get the current virtual Sp (it might not be zero,
-- eg. if we're compiling a let-no-escape).
(sp_top, stk_args) = mkVirtStkOffsets vSp other_args
-- Allocate the global ticky counter
- ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
+ ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
; emitTickyCounter cl_info args sp_top
-- ...and establish the ticky-counter
| otherwise = return noStmts
where
name = closureName cl_info
- slow_lbl = mkSlowEntryLabel name
+ has_caf_refs = clHasCafRefs cl_info
+ slow_lbl = mkSlowEntryLabel name has_caf_refs
load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts
(argMachRep rep))
save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
- mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
+ mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` 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)) []
+ jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) []
\end{code}
-- Stack and/or heap checks
; thunkEntryChecks closure_info $ do
- { -- Overwrite with black hole if necessary
- whenC (blackHoleOnEntry closure_info && node_points)
+ {
+ dflags <- getDynFlags
+ -- Overwrite with black hole if necessary
+ ; whenC (blackHoleOnEntry dflags closure_info && node_points)
(blackHoleIt closure_info)
; setupUpdate closure_info thunk_code }
-- setupUpdate *encloses* the thunk_code
funWrapper closure_info arg_regs reg_save_code fun_body = do
{ let node_points = nodeMustPointToIt (closureLFInfo closure_info)
+ {-
+ -- Debugging: check that R1 has the correct tag
+ ; let tag = funTag closure_info
+ ; whenC (tag /= 0 && node_points) $ do
+ l <- newLabelC
+ stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
+ CmmLit (mkIntCLit tag)]) l)
+ stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
+ labelC l
+ -}
+
-- Enter for Ldv profiling
- ; whenC node_points (ldvEnter (CmmReg nodeReg))
+ ; whenC node_points (ldvEnterClosure closure_info)
-- GranSim yeild poin
; granYield arg_regs node_points
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")
+emitBlackHoleCode is_single_entry = do
+
+ dflags <- getDynFlags
-- If we wanted to do eager blackholing with slop filling,
-- we'd need to do it at the *end* of a basic block, otherwise
-- 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
-
+ -- 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
+
+ let eager_blackholing = not opt_SccProfilingOn
+ && dopt Opt_EagerBlackHoling dflags
+
+ if eager_blackholing
+ then do
+ tickyBlackHole (not is_single_entry)
+ let bh_info = CmmReg (CmmGlobal EagerBlackholeInfo)
+ stmtsC [
+ CmmStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize)
+ (CmmReg (CmmGlobal CurrentTSO)),
+ CmmCall (CmmPrim MO_WriteBarrier) [] [] CmmUnsafe CmmMayReturn,
+ CmmStore (CmmReg nodeReg) bh_info
+ ]
+ else
+ nopC
\end{code}
\begin{code}
= code
| not (isStaticClosure closure_info)
- = if closureUpdReqd closure_info
- then do { tickyPushUpdateFrame; pushUpdateFrame (CmmReg nodeReg) code }
- else do { tickyUpdateFrameOmitted; code }
-
+ = do
+ if not (closureUpdReqd closure_info)
+ then do tickyUpdateFrameOmitted; code
+ else do
+ tickyPushUpdateFrame
+ dflags <- getDynFlags
+ if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+ then pushBHUpdateFrame (CmmReg nodeReg) code
+ else pushUpdateFrame (CmmReg nodeReg) 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 }
+ ; pushBHUpdateFrame 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)
+ { -- krc: removed some ticky-related code here.
; tickyUpdateFrameOmitted
; code }
}
-- 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
+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 []
+ tso = CmmReg (CmmGlobal CurrentTSO)
+ ; hp_offset <- allocDynClosure bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
; 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]
+ ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
+ [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
+ CmmHinted (CmmReg nodeReg) AddrHint ]
+ [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
; returnFC hp_rel }
where
bh_cl_info :: ClosureInfo
- bh_cl_info | is_upd = cafBlackHoleClosureInfo cl_info
- | otherwise = seCafBlackHoleClosureInfo cl_info
+ bh_cl_info = cafBlackHoleClosureInfo cl_info
ind_static_info :: CmmExpr
ind_static_info = mkLblExpr mkIndStaticInfoLabel
-- 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 '<' <>
+ = showSDocDumpOneLine (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.
+ -- showSDocDumpOneLine, because we want to see the unique on the Name.
\end{code}
projects / ghc-hetmet.git / blobdiff