From: simonpj@microsoft.com Date: Wed, 22 Sep 2010 13:37:41 +0000 (+0000) Subject: Fix an ASSERT failure with profiling X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=commitdiff_plain;h=9e6ca39b5e90b7a4acc755e3e95cc3ef60940070 Fix an ASSERT failure with profiling The problem arose with this kind of thing x = (,) (scc "blah" Nothing) Then 'x' is marked NoCafRefs by CoreTidy, becuase it has arity 1, and doesn't mention any caffy things. That in turns means that CorePrep must not float out the sat binding to give sat = scc "blah" Nothing x = (,) sat Rather we must generate x = \eta. let sat = scc "blah" Nothing in (,) sat eta URGH! This Caf stuff is such a mess. --- diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 6a5a251..ef5e75e 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -197,7 +197,7 @@ And then x will actually end up case-bound Note [CafInfo and floating] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -What happense when we try to float bindings to the top level. At this +What happens when we try to float bindings to the top level? At this point all the CafInfo is supposed to be correct, and we must make certain that is true of the new top-level bindings. There are two cases to consider @@ -297,16 +297,18 @@ cpePair :: TopLevelFlag -> RecFlag -> RhsDemand cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs = do { (floats1, rhs1) <- cpeRhsE env rhs - ; (floats2, rhs2) + -- See if we are allowed to float this stuff out of the RHS + ; (floats2, rhs2) <- float_from_rhs floats1 rhs1 + + -- Make the arity match up + ; (floats3, rhs') <- if manifestArity rhs1 <= arity - then return (floats1, cpeEtaExpand arity rhs1) + then return (floats2, cpeEtaExpand arity rhs2) else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr) -- Note [Silly extra arguments] (do { v <- newVar (idType bndr) - ; let float = mkFloat False False v rhs1 - ; return (addFloat floats1 float, cpeEtaExpand arity (Var v)) }) - - ; (floats3, rhs') <- float_from_rhs floats2 rhs2 + ; let float = mkFloat False False v rhs2 + ; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) }) -- Record if the binder is evaluated ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding @@ -317,37 +319,38 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs arity = idArity bndr -- We must match this arity --------------------- - float_from_rhs floats2 rhs2 - | isEmptyFloats floats2 = return (emptyFloats, rhs2) - | isTopLevel top_lvl = float_top floats2 rhs2 - | otherwise = float_nested floats2 rhs2 + float_from_rhs floats rhs + | isEmptyFloats floats = return (emptyFloats, rhs) + | isTopLevel top_lvl = float_top floats rhs + | otherwise = float_nested floats rhs --------------------- - float_nested floats2 rhs2 - | wantFloatNested is_rec is_strict_or_unlifted floats2 rhs2 - = return (floats2, rhs2) - | otherwise = dont_float floats2 rhs2 + float_nested floats rhs + | wantFloatNested is_rec is_strict_or_unlifted floats rhs + = return (floats, rhs) + | otherwise = dont_float floats rhs --------------------- - float_top floats2 rhs2 -- Urhgh! See Note [CafInfo and floating] + float_top floats rhs -- Urhgh! See Note [CafInfo and floating] | mayHaveCafRefs (idCafInfo bndr) - = if allLazyTop floats2 - then return (floats2, rhs2) - else dont_float floats2 rhs2 + , allLazyTop floats + = return (floats, rhs) + + -- So the top-level binding is marked NoCafRefs + | Just (floats', rhs') <- canFloatFromNoCaf floats rhs + = return (floats', rhs') | otherwise - = case canFloatFromNoCaf floats2 rhs2 of - Just (floats2', rhs2') -> return (floats2', rhs2') - Nothing -> pprPanic "cpePair" (ppr bndr $$ ppr rhs2 $$ ppr floats2) + = dont_float floats rhs --------------------- - dont_float floats2 rhs2 + dont_float floats rhs -- Non-empty floats, but do not want to float from rhs -- So wrap the rhs in the floats -- But: rhs1 might have lambdas, and we can't -- put them inside a wrapBinds - = do { body2 <- rhsToBodyNF rhs2 - ; return (emptyFloats, wrapBinds floats2 body2) } + = do { body <- rhsToBodyNF rhs + ; return (emptyFloats, wrapBinds floats body) } {- Note [Silly extra arguments] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -897,35 +900,50 @@ deFloatTop (Floats _ floats) canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -- Note [CafInfo and floating] canFloatFromNoCaf (Floats ok_to_spec fs) rhs - | OkToSpec <- ok_to_spec - = Just (Floats OkToSpec (toOL fs'), subst_expr subst rhs) + | OkToSpec <- ok_to_spec -- Worth trying + , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) + = Just (Floats OkToSpec fs', subst_expr subst rhs) | otherwise = Nothing where - (subst, fs') = mapAccumL set_nocaf emptySubst (fromOL fs) - subst_expr = substExpr (text "CorePrep") - set_nocaf _ (FloatCase {}) - = panic "canFloatFromNoCaf" + go :: (Subst, OrdList FloatingBind) -> [FloatingBind] + -> Maybe (Subst, OrdList FloatingBind) - set_nocaf subst (FloatLet (NonRec b r)) - = (subst', FloatLet (NonRec b' (subst_expr subst r))) + go (subst, fbs_out) [] = Just (subst, fbs_out) + + go (subst, fbs_out) (FloatLet (NonRec b r) : fbs_in) + | rhs_ok r + = go (subst', fbs_out `snocOL` new_fb) fbs_in where (subst', b') = set_nocaf_bndr subst b + new_fb = FloatLet (NonRec b' (subst_expr subst r)) - set_nocaf subst (FloatLet (Rec prs)) - = (subst', FloatLet (Rec (bs' `zip` rs'))) + go (subst, fbs_out) (FloatLet (Rec prs) : fbs_in) + | all rhs_ok rs + = go (subst', fbs_out `snocOL` new_fb) fbs_in where (bs,rs) = unzip prs (subst', bs') = mapAccumL set_nocaf_bndr subst bs rs' = map (subst_expr subst') rs + new_fb = FloatLet (Rec (bs' `zip` rs')) + + go _ _ = Nothing -- Encountered a caffy binding + ------------ set_nocaf_bndr subst bndr = (extendIdSubst subst bndr (Var bndr'), bndr') where bndr' = bndr `setIdCafInfo` NoCafRefs + ------------ + rhs_ok :: CoreExpr -> Bool + -- We can only float to top level from a NoCaf thing if + -- the new binding is static. However it can't mention + -- any non-static things or it would *already* be Caffy + rhs_ok = rhsIsStatic (\_ -> False) + wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec strict_or_unlifted floats rhs = isEmptyFloats floats diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 8284702..66d34b1 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -55,7 +55,6 @@ import SrcLoc import VarEnv import VarSet import Name -import Module #if mingw32_TARGET_OS import Packages #endif @@ -1337,7 +1336,7 @@ and 'execute' it rather than allocating it statically. -- | This function is called only on *top-level* right-hand sides. -- Returns @True@ if the RHS can be allocated statically in the output, -- with no thunks involved at all. -rhsIsStatic :: PackageId -> CoreExpr -> Bool +rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool -- It's called (i) in TidyPgm.hasCafRefs to decide if the rhs is, or -- refers to, CAFs; (ii) in CoreToStg to decide whether to put an -- update flag on it and (iii) in DsExpr to decide how to expand @@ -1392,7 +1391,7 @@ rhsIsStatic :: PackageId -> CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). -rhsIsStatic _this_pkg rhs = is_static False rhs +rhsIsStatic _is_dynamic_name rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool @@ -1420,7 +1419,7 @@ rhsIsStatic _this_pkg rhs = is_static False rhs where go (Var f) n_val_args #if mingw32_TARGET_OS - | not (isDllName _this_pkg (idName f)) + | not (_is_dynamic_name (idName f)) #endif = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) diff --git a/compiler/main/Packages.lhs b/compiler/main/Packages.lhs index a940f99..b080b95 100644 --- a/compiler/main/Packages.lhs +++ b/compiler/main/Packages.lhs @@ -947,6 +947,9 @@ missingDependencyMsg (Just parent) -- | Will the 'Name' come from a dynamically linked library? isDllName :: PackageId -> Name -> Bool +-- Despite the "dll", I think this function just means that +-- the synbol comes from another dynamically-linked package, +-- and applies on all platforms, not just Windows isDllName this_pkg name | opt_Static = False | Just mod <- nameModule_maybe name = modulePackageId mod /= this_pkg diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index c0952d6..a030983 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -37,6 +37,7 @@ import TcType import DataCon import TyCon import Module +import Packages( isDllName ) import HscTypes import Maybes import UniqSupply @@ -1139,12 +1140,12 @@ CAF list to keep track of non-collectable CAFs. \begin{code} hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo hasCafRefs this_pkg p arity expr - | is_caf || mentions_cafs - = MayHaveCafRefs + | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) - is_caf = not (arity > 0 || rhsIsStatic this_pkg expr) + is_dynamic_name = isDllName this_pkg + is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs index 370393b..3b004c1 100644 --- a/compiler/stgSyn/CoreToStg.lhs +++ b/compiler/stgSyn/CoreToStg.lhs @@ -12,7 +12,7 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreUtils ( rhsIsStatic, exprType, findDefault ) +import CoreUtils ( exprType, findDefault ) import CoreArity ( manifestArity ) import StgSyn @@ -184,7 +184,7 @@ coreTopBindToStg this_pkg env body_fvs (NonRec id rhs) bind = StgNonRec id stg_rhs in - ASSERT2(consistentCafInfo id bind, ppr id $$ ppr rhs $$ ppr bind ) + ASSERT2(consistentCafInfo id bind, ppr id {- $$ ppr rhs $$ ppr bind -} ) (env', fvs' `unionFVInfo` body_fvs, bind) coreTopBindToStg this_pkg env body_fvs (Rec pairs) @@ -214,15 +214,14 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs) -- floated out a binding, in which case it will be approximate. consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool consistentCafInfo id bind - | occNameFS (nameOccName (idName id)) == fsLit "sat" - = safe - | otherwise - = WARN (not exact, ppr id) safe + = WARN( not (exact || is_sat_thing) , ppr id ) + safe where - safe = id_marked_caffy || not binding_is_caffy - exact = id_marked_caffy == binding_is_caffy - id_marked_caffy = mayHaveCafRefs (idCafInfo id) - binding_is_caffy = stgBindHasCafRefs bind + safe = id_marked_caffy || not binding_is_caffy + exact = id_marked_caffy == binding_is_caffy + id_marked_caffy = mayHaveCafRefs (idCafInfo id) + binding_is_caffy = stgBindHasCafRefs bind + is_sat_thing = occNameFS (nameOccName (idName id)) == fsLit "sat" \end{code} \begin{code} @@ -236,13 +235,12 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) = do { (new_rhs, rhs_fvs, _) <- coreToStgExpr rhs ; lv_info <- freeVarsToLiveVars rhs_fvs - ; let stg_rhs = mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs + ; let stg_rhs = mkTopStgRhs this_pkg rhs_fvs (mkSRT lv_info) bndr_info new_rhs stg_arity = stgRhsArity stg_rhs ; return (ASSERT2( arity_ok stg_arity, mk_arity_msg stg_arity) stg_rhs, rhs_fvs) } where bndr_info = lookupFVInfo scope_fv_info bndr - is_static = rhsIsStatic this_pkg rhs -- It's vital that the arity on a top-level Id matches -- the arity of the generated STG binding, else an importing @@ -263,25 +261,23 @@ coreToTopStgRhs this_pkg scope_fv_info (bndr, rhs) ptext (sLit "Id arity:") <+> ppr id_arity, ptext (sLit "STG arity:") <+> ppr stg_arity] -mkTopStgRhs :: Bool -> FreeVarsInfo +mkTopStgRhs :: PackageId -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) - = ASSERT( is_static ) - StgRhsClosure noCCS binder_info +mkTopStgRhs _ rhs_fvs srt binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant srt bndrs body -mkTopStgRhs is_static _ _ _ (StgConApp con args) - | is_static -- StgConApps can be updatable (see isCrossDllConApp) +mkTopStgRhs this_pkg _ _ _ (StgConApp con args) + | not (isDllConApp this_pkg con args) -- Dynamic StgConApps are updatable = StgRhsCon noCCS con args -mkTopStgRhs is_static rhs_fvs srt binder_info rhs - = ASSERT2( not is_static, ppr rhs ) - StgRhsClosure noCCS binder_info +mkTopStgRhs _ rhs_fvs srt binder_info rhs + = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) Updatable srt diff --git a/compiler/stgSyn/StgSyn.lhs b/compiler/stgSyn/StgSyn.lhs index 973514c..3bce281 100644 --- a/compiler/stgSyn/StgSyn.lhs +++ b/compiler/stgSyn/StgSyn.lhs @@ -48,12 +48,11 @@ module StgSyn ( import CostCentre ( CostCentreStack, CostCentre ) import VarSet ( IdSet, isEmptyVarSet ) -import Id ( Id, idName, idType, idCafInfo, isId ) +import Id +import DataCon import IdInfo ( mayHaveCafRefs ) -import Packages ( isDllName ) import Literal ( Literal, literalType ) import ForeignCall ( ForeignCall ) -import DataCon ( DataCon, dataConName ) import CoreSyn ( AltCon ) import PprCore ( {- instances -} ) import PrimOp ( PrimOp, PrimCall ) @@ -66,6 +65,11 @@ import Bitmap import StaticFlags ( opt_SccProfilingOn ) import Module import FastString + +#if mingw32_TARGET_OS +import Packages ( isDllName ) + +#endif \end{code} %************************************************************************ @@ -105,17 +109,20 @@ isStgTypeArg :: StgArg -> Bool isStgTypeArg (StgTypeArg _) = True isStgTypeArg _ = False -isDllArg :: PackageId -> StgArg -> Bool - -- Does this argument refer to something in a different DLL? -isDllArg this_pkg (StgVarArg v) = isDllName this_pkg (idName v) -isDllArg _ _ = False - isDllConApp :: PackageId -> DataCon -> [StgArg] -> Bool - -- Does this constructor application refer to - -- anything in a different DLL? - -- If so, we can't allocate it statically +-- Does this constructor application refer to +-- anything in a different *Windows* DLL? +-- If so, we can't allocate it statically +#if mingw32_TARGET_OS isDllConApp this_pkg con args - = isDllName this_pkg (dataConName con) || any (isDllArg this_pkg) args + = isDllName this_pkg (dataConName con) || any is_dll_arg args + where + is_dll_arg ::StgArg -> Bool + is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v) + is_dll_arg _ = False +#else +isDllConApp _ _ _ = False +#endif stgArgType :: StgArg -> Type -- Very half baked becase we have lost the type arguments