Commit 41448969 authored by ian@well-typed.com's avatar ian@well-typed.com
Browse files

Remove CPP from coreSyn/CoreUtils.lhs

parent baa7c0fd
......@@ -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
......
......@@ -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
......
......@@ -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
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment