From: simonpj Date: Mon, 29 Jul 2002 16:12:08 +0000 (+0000) Subject: [project @ 2002-07-29 16:12:07 by simonpj] X-Git-Tag: Approx_11550_changesets_converted~1790 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=90b4aa6cff4a95d9fe205b2bf24e28ba505d2bfe;p=ghc-hetmet.git [project @ 2002-07-29 16:12:07 by simonpj] ** MERGE TO STABLE ** 1. Make TidyPgm forget IdInfo for exported things. This is really important for the recompilation checker; see the commment with TidyPgm.tidyTopIdInfo Fixes a bug reported by Sigbjorn. 2. Make CoreToStg more robust, by avoiding the duplicate calculation of update flag for top-level closures --- diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 3bfcb0b..8c57005 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -492,24 +492,33 @@ tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs tidy_rhs -- of Ids, and rules, right at the top, but that would be a pain. tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info - | opt_OmitInterfacePragmas || not is_external - -- Only basic info if the Id isn't external, or if we don't have -O - = basic_info - - | otherwise -- Add extra optimisation info - = basic_info + | opt_OmitInterfacePragmas -- If the interface file has no pragma info + = vanillaIdInfo -- then discard all info right here + -- This is not so important for *this* module, but it's + -- vital for ghc --make: + -- subsequent compilations must not see (e.g.) the arity if + -- the interface file does not contain arity + -- If they do, they'll exploit the arity; then the arity might + -- change, but the iface file doesn't change => recompilation + -- does not happen => disaster + + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setCgInfo` cg_info + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo) -- NB: we throw away the Rules -- They have already been extracted by findExternalRules - - where - -- baasic_info is attached to every top-level binder - basic_info = vanillaIdInfo - `setCgInfo` cg_info - `setArityInfo` arity - `setAllStrictnessInfo` newStrictnessInfo idinfo -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 1db8794..e1139b9 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -35,7 +35,7 @@ import OccName ( occNameUserString ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) import FastTypes hiding ( fastOr ) -import Util ( listLengthCmp ) +import Util ( listLengthCmp, mapAndUnzip ) import Outputable infixr 9 `thenLne` @@ -175,20 +175,19 @@ coreTopBindToStg coreTopBindToStg env body_fvs (NonRec id rhs) = let - caf_info = hasCafRefs env rhs + (caf_info, upd) = hasCafRefs env rhs env' = extendVarEnv env id how_bound how_bound = LetBound (TopLet caf_info) (manifestArity rhs) (stg_rhs, fvs', lv_info) = initLne env ( - coreToStgRhs body_fvs TopLevel (id,rhs) `thenLne` \ (stg_rhs, fvs', _) -> + coreToTopStgRhs body_fvs ((id,rhs), upd) `thenLne` \ (stg_rhs, fvs') -> freeVarsToLiveVars fvs' `thenLne` \ lv_info -> returnLne (stg_rhs, fvs', lv_info) ) bind = StgNonRec (mkSRT lv_info) id stg_rhs in - ASSERT2(isLocalId id || idArity id == manifestArity rhs, ppr id) ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(consistent caf_info bind, ppr id) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) @@ -200,28 +199,31 @@ coreTopBindToStg env body_fvs (Rec pairs) -- To calculate caf_info, we initially map -- all the binders to NoCafRefs - env1 = extendVarEnvList env - [ (b, LetBound (TopLet NoCafRefs) (error "no arity")) - | b <- binders ] - - caf_info = hasCafRefss env1{-NB: not env'-} rhss + extra_env = [ (b, LetBound (TopLet NoCafRefs) (manifestArity rhs)) + | (b,rhs) <- pairs ] + env1 = extendVarEnvList env extra_env + (caf_infos, upd_flags) = mapAndUnzip (hasCafRefs env1) rhss + -- NB: use env1 not env' + + -- If any has a CAF ref, they all do + caf_info | any mayHaveCafRefs caf_infos = MayHaveCafRefs + | otherwise = NoCafRefs - env' = extendVarEnvList env - [ (b, LetBound (TopLet caf_info) (manifestArity rhs)) - | (b,rhs) <- pairs ] + extra_env' = [ (b, LetBound (TopLet caf_info) arity) + | (b, LetBound _ arity) <- extra_env ] + env' = extendVarEnvList env extra_env' (stg_rhss, fvs', lv_info) = initLne env' ( - mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs - `thenLne` \ (stg_rhss, fvss', _) -> + mapAndUnzipLne (coreToTopStgRhs body_fvs) + (pairs `zip` upd_flags) `thenLne` \ (stg_rhss, fvss') -> let fvs' = unionFVInfos fvss' in - freeVarsToLiveVars fvs' `thenLne` \ lv_info -> + freeVarsToLiveVars fvs' `thenLne` \ lv_info -> returnLne (stg_rhss, fvs', lv_info) ) bind = StgRec (mkSRT lv_info) (zip binders stg_rhss) in - ASSERT2(and [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders) ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistent caf_info bind, ppr binders) -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) @@ -232,82 +234,35 @@ consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind \end{code} \begin{code} -coreToStgRhs +coreToTopStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> TopLevelFlag - -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) + -> ((Id,CoreExpr), UpdateFlag) + -> LneM (StgRhs, FreeVarsInfo) -coreToStgRhs scope_fv_info top (binder, rhs) - = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> - returnLne (mkStgRhs top rhs_fvs binder_info new_rhs, - rhs_fvs, rhs_escs) +coreToTopStgRhs scope_fv_info ((bndr, rhs), upd) + = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) -> + returnLne (mkTopStgRhs upd rhs_fvs bndr_info new_rhs, rhs_fvs) where - binder_info = lookupFVInfo scope_fv_info binder + bndr_info = lookupFVInfo scope_fv_info bndr -mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo - -> StgExpr -> StgRhs +mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo + -> StgExpr -> StgRhs -mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body) +mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant bndrs body -mkStgRhs top rhs_fvs binder_info (StgConApp con args) - | isNotTopLevel top || not (isDllConApp con args) +mkTopStgRhs ReEntrant rhs_fvs binder_info (StgConApp con args) + -- StgConApps can be Updatable: see isCrossDllConApp below = StgRhsCon noCCS con args -mkStgRhs top rhs_fvs binder_info rhs +mkTopStgRhs upd_flag rhs_fvs binder_info rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - (updatable [] rhs) + upd_flag [] rhs - where - updatable args body | null args && isPAP body = ReEntrant - | otherwise = Updatable -{- ToDo: - upd = if isOnceDem dem - then (if isNotTop toplev - then SingleEntry -- HA! Paydirt for "dem" - else -#ifdef DEBUG - trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ -#endif - Updatable) - else Updatable - -- For now we forbid SingleEntry CAFs; they tickle the - -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, - -- and I don't understand why. There's only one SE_CAF (well, - -- only one that tickled a great gaping bug in an earlier attempt - -- at ClosureInfo.getEntryConvention) in the whole of nofib, - -- specifically Main.lvl6 in spectral/cryptarithm2. - -- So no great loss. KSW 2000-07. --} -\end{code} - -Detect thunks which will reduce immediately to PAPs, and make them -non-updatable. This has several advantages: - - - the non-updatable thunk behaves exactly like the PAP, - - - the thunk is more efficient to enter, because it is - specialised to the task. - - - we save one update frame, one stg_update_PAP, one update - and lots of PAP_enters. - - - in the case where the thunk is top-level, we save building - a black hole and futhermore the thunk isn't considered to - be a CAF any more, so it doesn't appear in any SRTs. - -We do it here, because the arity information is accurate, and we need -to do it before the SRT pass to save the SRT entries associated with -any top-level PAPs. - -\begin{code} -isPAP (StgApp f args) = listLengthCmp args (idArity f) == LT -- idArity f > length args -isPAP _ = False \end{code} @@ -513,10 +468,7 @@ coreToStgApp maybe_thunk_body f args -- No point in having correct arity info for f! -- Hence the hasArity stuff below. -- NB: f_arity is only consulted for LetBound things - f_arity = case how_bound of - LetBound _ arity -> arity - ImportBound -> idArity f - + f_arity = stgArity f how_bound saturated = f_arity <= n_val_args fun_occ @@ -697,7 +649,7 @@ coreToStgLet let_no_escape bind body vars_bind body_fvs (NonRec binder rhs) - = coreToStgRhs body_fvs NotTopLevel (binder,rhs) + = coreToStgRhs body_fvs (binder,rhs) `thenLne` \ (rhs2, bind_fvs, escs) -> freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info -> @@ -717,7 +669,7 @@ coreToStgLet let_no_escape bind body | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( - mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs + mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs) pairs `thenLne` \ (rhss2, fvss, escss) -> let bind_fvs = unionFVInfos fvss @@ -737,6 +689,83 @@ is_join_var :: Id -> Bool is_join_var j = occNameUserString (getOccName j) == "$j" \end{code} +\begin{code} +coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) + +coreToStgRhs scope_fv_info (bndr, rhs) + = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> + getEnvLne `thenLne` \ env -> + returnLne (mkStgRhs env rhs_fvs bndr_info new_rhs, + rhs_fvs, rhs_escs) + where + bndr_info = lookupFVInfo scope_fv_info bndr + +mkStgRhs :: IdEnv HowBound -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs + +mkStgRhs env rhs_fvs binder_info (StgConApp con args) + = StgRhsCon noCCS con args + +mkStgRhs env rhs_fvs binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + bndrs body + +mkStgRhs env rhs_fvs binder_info rhs + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + upd_flag [] rhs + where + upd_flag | isPAP env rhs = ReEntrant + | otherwise = Updatable +{- ToDo: + upd = if isOnceDem dem + then (if isNotTop toplev + then SingleEntry -- HA! Paydirt for "dem" + else +#ifdef DEBUG + trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ +#endif + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. +-} +\end{code} + +Detect thunks which will reduce immediately to PAPs, and make them +non-updatable. This has several advantages: + + - the non-updatable thunk behaves exactly like the PAP, + + - the thunk is more efficient to enter, because it is + specialised to the task. + + - we save one update frame, one stg_update_PAP, one update + and lots of PAP_enters. + + - in the case where the thunk is top-level, we save building + a black hole and futhermore the thunk isn't considered to + be a CAF any more, so it doesn't appear in any SRTs. + +We do it here, because the arity information is accurate, and we need +to do it before the SRT pass to save the SRT entries associated with +any top-level PAPs. + +\begin{code} +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False +\end{code} + %************************************************************************ %* * @@ -773,6 +802,7 @@ data HowBound data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live? -- Invariant: the binder itself is always a member of -- the dynamic set of its own LiveInfo + | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one? isLetBound (LetBound _ _) = True @@ -885,6 +915,9 @@ extendVarEnvLne ids_w_howbound expr env lvs_cont lookupVarLne :: Id -> LneM HowBound lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont +getEnvLne :: LneM (IdEnv HowBound) +getEnvLne env lvs_cont = returnLne env env lvs_cont + lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of Just xx -> xx @@ -1079,23 +1112,15 @@ it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. \begin{code} -hasCafRefs :: IdEnv HowBound -> CoreExpr -> CafInfo --- Only called for the RHS of top-level lets -hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo - -- predicate returns True for a given Id if we look at this Id when - -- calculating the result. Used to *avoid* looking at the CafInfo - -- field for an Id that is part of the current recursive group. - +hasCafRefs :: IdEnv HowBound -> CoreExpr -> (CafInfo, UpdateFlag) hasCafRefs p expr - | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs - | otherwise = NoCafRefs - - -- used for recursive groups. The whole group is set to - -- "MayHaveCafRefs" if at least one of the group is a CAF or - -- refers to any CAFs. -hasCafRefss p exprs - | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs - | otherwise = NoCafRefs + | is_caf || mentions_cafs = (MayHaveCafRefs, upd_flag) + | otherwise = (NoCafRefs, ReEntrant) + where + mentions_cafs = isFastTrue (cafRefs p expr) + is_caf = not (rhsIsNonUpd p expr) + upd_flag | is_caf = Updatable + | otherwise = ReEntrant -- The environment that cafRefs uses has top-level bindings *only*. -- We don't bother to add local bindings as cafRefs traverses the expression @@ -1106,9 +1131,9 @@ hasCafRefss p exprs cafRefs p (Var id) = case lookupVarEnv p id of Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info) - Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported + Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported | otherwise -> fastBool False -- Nested binder - _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env + _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env cafRefs p (Lit l) = fastBool False cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a @@ -1124,13 +1149,8 @@ cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es -- hack for lazy-or over FastBool. fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) -isCAF :: CoreExpr -> Bool --- Only called for the RHS of top-level lets -isCAF e = not (rhsIsNonUpd e) - {- ToDo: check type for onceness, i.e. non-updatable thunks? -} - -rhsIsNonUpd :: CoreExpr -> Bool +rhsIsNonUpd :: IdEnv HowBound -> CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -- This is a bit like CoreUtils.exprIsValue, with the following differences: -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) @@ -1145,13 +1165,13 @@ rhsIsNonUpd :: CoreExpr -> Bool -- -- When opt_RuntimeTypes is on, we keep type lambdas and treat -- them as making the RHS re-entrant (non-updatable). -rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e -rhsIsNonUpd (Note (SCC _) e) = False -rhsIsNonUpd (Note _ e) = rhsIsNonUpd e -rhsIsNonUpd other_expr +rhsIsNonUpd p (Lam b e) = isRuntimeVar b || rhsIsNonUpd p e +rhsIsNonUpd p (Note (SCC _) e) = False +rhsIsNonUpd p (Note _ e) = rhsIsNonUpd p e +rhsIsNonUpd p other_expr = go other_expr 0 [] where - go (Var f) n_args args = idAppIsNonUpd f n_args args + go (Var f) n_args args = idAppIsNonUpd p f n_args args go (App f a) n_args args | isTypeArg a = go f n_args args @@ -1162,10 +1182,15 @@ rhsIsNonUpd other_expr go other n_args args = False -idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool -idAppIsNonUpd id n_val_args args +idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool +idAppIsNonUpd p id n_val_args args | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) - | otherwise = n_val_args < idArity id + | otherwise = n_val_args < stgArity id (lookupBinding p id) + +stgArity :: Id -> HowBound -> Arity +stgArity f (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity f LambdaBound = 0 isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args @@ -1176,7 +1201,7 @@ isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg arg -- (because we can't refer to static labels in other DLLs). -- If this happens we simply make the RHS into an updatable thunk, -- and 'exectute' it rather than allocating it statically. --- All this should match the decision in (see CoreToStg.coreToStgRhs) +-- All this should match the decision in (see CoreToStg.mkStgRhs) isCrossDllArg :: CoreExpr -> Bool