diff options
Diffstat (limited to 'compiler/codeGen/StgCmmBind.hs')
| -rw-r--r-- | compiler/codeGen/StgCmmBind.hs | 84 |
1 files changed, 40 insertions, 44 deletions
diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0ba99aed36..ce5491dc10 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -22,7 +22,6 @@ import StgCmmCon import StgCmmHeap import StgCmmProf import StgCmmTicky -import StgCmmGran import StgCmmLayout import StgCmmUtils import StgCmmClosure @@ -58,22 +57,21 @@ import Control.Monad -- For closures bound at top level, allocate in static space. -- They should have no free variables. -cgTopRhsClosure :: RecFlag -- member of a recursive group? +cgTopRhsClosure :: DynFlags + -> RecFlag -- member of a recursive group? -> Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo -> UpdateFlag -> [Id] -- Args -> StgExpr - -> FCode (CgIdInfo, FCode ()) - -cgTopRhsClosure rec id ccs _ upd_flag args body - = do { dflags <- getDynFlags - ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args - ; let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) - cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) - ; return (cg_id_info, gen_code dflags lf_info closure_label) - } + -> (CgIdInfo, FCode ()) + +cgTopRhsClosure dflags rec id ccs _ upd_flag args body = + let closure_label = mkLocalClosureLabel (idName id) (idCafInfo id) + cg_id_info = litIdInfo dflags id lf_info (CmmLabel closure_label) + lf_info = mkClosureLFInfo dflags id TopLevel [] upd_flag args + in (cg_id_info, gen_code dflags lf_info closure_label) where -- special case for a indirection (f = g). We create an IND_STATIC -- closure pointing directly to the indirectee. This is exactly @@ -106,7 +104,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body caffy = idCafInfo id info_tbl = mkCmmInfo closure_info -- XXX short-cut closure_rep = mkStaticClosureFields dflags info_tbl ccs caffy [] - + -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] @@ -115,7 +113,7 @@ cgTopRhsClosure rec id ccs _ upd_flag args body -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs (nonVoidIds args) (length args) body fv_details) - + ; return () } unLit (CmmLit l) = l @@ -128,10 +126,9 @@ cgTopRhsClosure rec id ccs _ upd_flag args body cgBind :: StgBinding -> FCode () cgBind (StgNonRec name rhs) = do { (info, fcode) <- cgRhs name rhs - ; addBindC (cg_id info) info + ; addBindC info ; init <- fcode - ; emit init - } + ; emit init } -- init cannot be used in body, so slightly better to sink it eagerly cgBind (StgRec pairs) @@ -205,9 +202,10 @@ cgRhs :: Id ) cgRhs id (StgRhsCon cc con args) - = withNewTickyCounterThunk (idName id) $ + = withNewTickyCounterThunk False (idName id) $ -- False for "not static" buildDynCon id True cc con args +{- See Note [GC recovery] in compiler/codeGen/StgCmmClosure.hs -} cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body) = do dflags <- getDynFlags mkRhsClosure dflags name cc bi (nonVoidIds fvs) upd_flag args body @@ -316,8 +314,8 @@ mkRhsClosure dflags bndr _cc _bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure _ bndr cc _ fvs upd_flag args body - = do { lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args +mkRhsClosure dflags bndr cc _ fvs upd_flag args body + = do { let lf_info = mkClosureLFInfo dflags bndr NotTopLevel fvs upd_flag args ; (id_info, reg) <- rhsIdInfo bndr lf_info ; return (id_info, gen_code lf_info reg) } where @@ -383,7 +381,7 @@ cgRhsStdThunk bndr lf_info payload } where gen_code reg -- AHA! A STANDARD-FORM THUNK - = withNewTickyCounterStdThunk (idName bndr) $ + = withNewTickyCounterStdThunk False (idName bndr) $ -- False for "not static" do { -- LAY OUT THE OBJECT mod_name <- getModuleName @@ -399,7 +397,7 @@ cgRhsStdThunk bndr lf_info payload -- ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body ; let use_cc = curCCS; blame_cc = curCCS - ; tickyEnterStdThunk + ; tickyEnterStdThunk closure_info -- BUILD THE OBJECT ; let info_tbl = mkCmmInfo closure_info @@ -410,21 +408,22 @@ cgRhsStdThunk bndr lf_info payload ; return (mkRhsInit dflags reg lf_info hp_plus_n) } -mkClosureLFInfo :: Id -- The binder +mkClosureLFInfo :: DynFlags + -> Id -- The binder -> TopLevelFlag -- True of top level -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> FCode LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag) + -> LambdaFormInfo +mkClosureLFInfo dflags bndr top fvs upd_flag args + | null args = + mkLFThunk (idType bndr) top (map unsafe_stripNV fvs) upd_flag | otherwise = - do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top (map unsafe_stripNV fvs) args arg_descr) } + mkLFReEntrant top (map unsafe_stripNV fvs) args (mkArgDescr dflags args) ------------------------------------------------------------------------ --- The code for closures} +-- The code for closures ------------------------------------------------------------------------ closureCodeBody :: Bool -- whether this is a top-level binding @@ -452,8 +451,7 @@ closureCodeBody :: Bool -- whether this is a top-level binding closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details | arity == 0 -- No args i.e. thunk - = ASSERT ( not (isStaticClosure cl_info) ) - withNewTickyCounterThunk (closureName cl_info) $ + = withNewTickyCounterThunk (isStaticClosure cl_info) (closureName cl_info) $ emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body where @@ -478,7 +476,6 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details ; let node_points = nodeMustPointToIt dflags lf_info node' = if node_points then Just node else Nothing ; when node_points (ldvEnterClosure cl_info) - ; granYield arg_regs node_points -- Main payload ; entryHeapCheck cl_info node' arity arg_regs $ do @@ -542,14 +539,14 @@ thunkCode cl_info fv_details _cc node arity body ; let node_points = nodeMustPointToIt dflags (closureLFInfo cl_info) node' = if node_points then Just node else Nothing ; ldvEnterClosure cl_info -- NB: Node always points when profiling - ; granThunk node_points -- Heap overflow check ; entryHeapCheck cl_info node' arity [] $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check + ; tickyEnterThunk cl_info ; when (blackHoleOnEntry cl_info && node_points) - (blackHoleIt cl_info node) + (blackHoleIt node) -- Push update frame ; setupUpdate cl_info node $ @@ -557,7 +554,7 @@ thunkCode cl_info fv_details _cc node arity body -- that cc of enclosing scope will be recorded -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc - do { tickyEnterThunk + do { tickyEnterThunk cl_info ; enterCostCentreThunk (CmmReg nodeReg) ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details @@ -569,20 +566,20 @@ thunkCode cl_info fv_details _cc node arity body -- Update and black-hole wrappers ------------------------------------------------------------------------ -blackHoleIt :: ClosureInfo -> LocalReg -> FCode () +blackHoleIt :: LocalReg -> FCode () -- Only called for closures with no args -- Node points to the closure -blackHoleIt closure_info node - = emitBlackHoleCode (closureSingleEntry closure_info) (CmmReg (CmmLocal node)) +blackHoleIt node_reg + = emitBlackHoleCode (CmmReg (CmmLocal node_reg)) -emitBlackHoleCode :: Bool -> CmmExpr -> FCode () -emitBlackHoleCode is_single_entry node = do +emitBlackHoleCode :: CmmExpr -> FCode () +emitBlackHoleCode node = do dflags <- getDynFlags -- Eager blackholing is normally disabled, but can be turned on with -- -feager-blackholing. When it is on, we replace the info pointer -- of the thunk with stg_EAGER_BLACKHOLE_info on entry. - + -- 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 @@ -593,7 +590,7 @@ emitBlackHoleCode is_single_entry node = do -- 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 - + -- Note the eager-blackholing check is here rather than in blackHoleOnEntry, -- because emitBlackHoleCode is called from CmmParse. @@ -604,7 +601,6 @@ emitBlackHoleCode is_single_entry node = do -- work with profiling. when eager_blackholing $ do - tickyBlackHole (not is_single_entry) emitStore (cmmOffsetW dflags node (fixedHdrSize dflags)) (CmmReg (CmmGlobal CurrentTSO)) emitPrimCall [] MO_WriteBarrier [] @@ -615,7 +611,7 @@ setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- so that the cost centre in the original closure can still be -- extracted by a subsequent enterCostCentre setupUpdate closure_info node body - | closureReEntrant closure_info + | not (lfUpdatable (closureLFInfo closure_info)) = body | not (isStaticClosure closure_info) @@ -736,7 +732,7 @@ link_caf node _is_upd = do -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion ; ret <- newTemp (bWord dflags) - ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF") + ; emitRtsCallGen [(ret,NoHint)] (mkForeignLabel (fsLit "newCAF") Nothing ForeignLabelInExternalPackage IsFunction) [ (CmmReg (CmmGlobal BaseReg), AddrHint), (CmmReg (CmmLocal node), AddrHint), (hp_rel, AddrHint) ] |