Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/41448969dad90e479e4eac3721fc5d5dd4968885 >--------------------------------------------------------------- commit 41448969dad90e479e4eac3721fc5d5dd4968885 Author: Ian Lynagh <[email protected]> Date: Wed Aug 29 00:10:44 2012 +0100 Remove CPP from coreSyn/CoreUtils.lhs >--------------------------------------------------------------- compiler/coreSyn/CorePrep.lhs | 11 +++++++---- compiler/coreSyn/CoreUtils.lhs | 10 +++++----- compiler/main/TidyPgm.lhs | 23 ++++++++++++++--------- 3 files changed, 26 insertions(+), 18 deletions(-) diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index 5a996c8..0bd199f 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -46,6 +46,7 @@ import DynFlags import Util import Pair import Outputable +import Platform import FastString import Config import Data.Bits @@ -401,6 +402,8 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs ; return (floats3, bndr', rhs') } where + platform = targetPlatform (cpe_dynFlags env) + arity = idArity bndr -- We must match this arity --------------------- @@ -422,7 +425,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs = return (floats, rhs) -- So the top-level binding is marked NoCafRefs - | Just (floats', rhs') <- canFloatFromNoCaf floats rhs + | Just (floats', rhs') <- canFloatFromNoCaf platform floats rhs = return (floats', rhs') | otherwise @@ -1069,9 +1072,9 @@ dropDeadCodeAlts alts = (alts', unionVarSets fvss) where !(e', fvs) = dropDeadCode e ------------------------------------------- -canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) +canFloatFromNoCaf :: Platform -> Floats -> CpeRhs -> Maybe (Floats, CpeRhs) -- Note [CafInfo and floating] -canFloatFromNoCaf (Floats ok_to_spec fs) rhs +canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs | OkToSpec <- ok_to_spec -- Worth trying , Just (subst, fs') <- go (emptySubst, nilOL) (fromOL fs) = Just (Floats OkToSpec fs', subst_expr subst rhs) @@ -1114,7 +1117,7 @@ canFloatFromNoCaf (Floats ok_to_spec fs) rhs -- 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) + rhs_ok = rhsIsStatic platform (\_ -> False) wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec strict_or_unlifted floats rhs diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs index 12a3fb3..f15c648 100644 --- a/compiler/coreSyn/CoreUtils.lhs +++ b/compiler/coreSyn/CoreUtils.lhs @@ -66,6 +66,7 @@ import Outputable import TysPrim import FastString import Maybes +import Platform import Util import Pair import Data.Word @@ -1733,7 +1734,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 :: (Name -> Bool) -> CoreExpr -> Bool +rhsIsStatic :: Platform -> (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 @@ -1788,7 +1789,7 @@ rhsIsStatic :: (Name -> Bool) -> CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). -rhsIsStatic _is_dynamic_name rhs = is_static False rhs +rhsIsStatic platform is_dynamic_name rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool @@ -1813,9 +1814,8 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs is_static in_arg other_expr = go other_expr 0 where go (Var f) n_val_args -#if mingw32_TARGET_OS - | not (_is_dynamic_name (idName f)) -#endif + | (platformOS platform /= OSMinGW32) || + not (is_dynamic_name (idName f)) = saturated_data_con f n_val_args || (in_arg && n_val_args == 0) -- A naked un-applied variable is *not* deemed a static RHS diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs index 85127e6..bea9f14 100644 --- a/compiler/main/TidyPgm.lhs +++ b/compiler/main/TidyPgm.lhs @@ -47,6 +47,7 @@ import Module import Packages( isDllName ) import HscTypes import Maybes +import Platform import UniqSupply import ErrUtils (Severity(..)) import Outputable @@ -1048,34 +1049,37 @@ tidyTopBinds hsc_env unfold_env init_occ_env binds $ initTcForLookup hsc_env (tcLookupGlobal mkIntegerName) return $ tidy mkIntegerId init_env binds where + platform = targetPlatform (hsc_dflags hsc_env) + init_env = (init_occ_env, emptyVarEnv) this_pkg = thisPackage (hsc_dflags hsc_env) tidy _ env [] = (env, []) - tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind this_pkg mkIntegerId unfold_env env b + tidy mkIntegerId env (b:bs) = let (env1, b') = tidyTopBind platform this_pkg mkIntegerId unfold_env env b (env2, bs') = tidy mkIntegerId env1 bs in (env2, b':bs') ------------------------ -tidyTopBind :: PackageId +tidyTopBind :: Platform + -> PackageId -> Id -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) +tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (NonRec bndr rhs) = (tidy_env2, NonRec bndr' rhs') where Just (name',show_unfold) = lookupVarEnv unfold_env bndr - caf_info = hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs + caf_info = hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs (bndr', rhs') = tidyTopPair show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) +tidyTopBind platform this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1092,7 +1096,7 @@ tidyTopBind this_pkg mkIntegerId unfold_env (occ_env,subst1) (Rec prs) -- the CafInfo for a recursive group says whether *any* rhs in -- the group may refer indirectly to a CAF (because then, they all do). caf_info - | or [ mayHaveCafRefs (hasCafRefs this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs platform this_pkg (mkIntegerId, subst1) (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1229,14 +1233,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 :: PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr -> CafInfo -hasCafRefs this_pkg p arity expr +hasCafRefs :: Platform -> PackageId -> (Id, VarEnv Var) -> Arity -> CoreExpr + -> CafInfo +hasCafRefs platform this_pkg p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefsE p expr) is_dynamic_name = isDllName this_pkg - is_caf = not (arity > 0 || rhsIsStatic is_dynamic_name expr) + is_caf = not (arity > 0 || rhsIsStatic platform 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 _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
