diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-16 17:53:00 +0000 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2014-12-17 14:45:47 +0000 |
commit | 6b11bab6961a1518a15eaa3d3b4ce40702724ca5 (patch) | |
tree | 3a1602c0b451b9fd77ce6f4075d23f9372fa9b17 | |
parent | 67a0cab6b501e2d6280b51655af66ad448b3deef (diff) | |
download | haskell-6b11bab6961a1518a15eaa3d3b4ce40702724ca5.tar.gz |
Improve TidyPgm.hasCafRefs to account for Integer literals (Trac #8525)
See Note [Disgusting computation of CafRefs] in TidyPgm.
Also affects CoreUtils.rhsIsStatic.
The real solution here is to compute CAF and arity information
from the STG-program, and feed it back to tidied program for
the interface file and later GHCi clients. A battle for another
day.
But at least this commit reduces the number of gratuitous CAFs, and
hence SRT entries. And kills off a batch of ASSERT failures.
-rw-r--r-- | compiler/coreSyn/CorePrep.hs | 2 | ||||
-rw-r--r-- | compiler/coreSyn/CoreUtils.hs | 25 | ||||
-rw-r--r-- | compiler/main/TidyPgm.hs | 100 | ||||
-rw-r--r-- | testsuite/tests/lib/integer/all.T | 3 |
4 files changed, 74 insertions, 56 deletions
diff --git a/compiler/coreSyn/CorePrep.hs b/compiler/coreSyn/CorePrep.hs index 1ca54fe6aa..924dfb4825 100644 --- a/compiler/coreSyn/CorePrep.hs +++ b/compiler/coreSyn/CorePrep.hs @@ -1109,6 +1109,8 @@ canFloatFromNoCaf platform (Floats ok_to_spec fs) rhs -- the new binding is static. However it can't mention -- any non-static things or it would *already* be Caffy rhs_ok = rhsIsStatic platform (\_ -> False) + (\i -> pprPanic "rhsIsStatic" (integer i)) + -- Integer literals should not show up wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool wantFloatNested is_rec strict_or_unlifted floats rhs diff --git a/compiler/coreSyn/CoreUtils.hs b/compiler/coreSyn/CoreUtils.hs index cfc4c45737..c5200294da 100644 --- a/compiler/coreSyn/CoreUtils.hs +++ b/compiler/coreSyn/CoreUtils.hs @@ -1964,7 +1964,12 @@ 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 :: Platform -> (Name -> Bool) -> CoreExpr -> Bool +rhsIsStatic :: Platform + -> (Name -> Bool) -- Which names are dynamic + -> (Integer -> CoreExpr) -- Desugaring for integer literals (disgusting) + -- C.f. Note [Disgusting computation of CafRefs] + -- in TidyPgm + -> 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 @@ -2019,19 +2024,19 @@ rhsIsStatic :: Platform -> (Name -> Bool) -> CoreExpr -> Bool -- -- c) don't look through unfolding of f in (f x). -rhsIsStatic platform is_dynamic_name rhs = is_static False rhs +rhsIsStatic platform is_dynamic_name cvt_integer rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic -> CoreExpr -> Bool - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Tick n e) = not (tickishIsCode n) - && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e - is_static _ (Coercion {}) = True -- Behaves just like a literal - is_static _ (Lit (LitInteger {})) = False - is_static _ (Lit (MachLabel {})) = False - is_static _ (Lit _) = True + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Tick n e) = not (tickishIsCode n) + && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e + is_static _ (Coercion {}) = True -- Behaves just like a literal + is_static in_arg (Lit (LitInteger i _)) = is_static in_arg (cvt_integer i) + is_static _ (Lit (MachLabel {})) = False + is_static _ (Lit _) = True -- A MachLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The -- reason is that it might give rise to unresolvable symbols diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs index 579d979cd6..a616dde373 100644 --- a/compiler/main/TidyPgm.hs +++ b/compiler/main/TidyPgm.hs @@ -1105,7 +1105,8 @@ tidyTopBinds :: HscEnv tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds = do mkIntegerId <- lookupMkIntegerName dflags hsc_env integerSDataCon <- lookupIntegerSDataConName dflags hsc_env - return $ tidy mkIntegerId integerSDataCon init_env binds + let cvt_integer = cvtLitInteger dflags mkIntegerId integerSDataCon + return $ tidy cvt_integer init_env binds where dflags = hsc_dflags hsc_env @@ -1113,37 +1114,35 @@ tidyTopBinds hsc_env this_mod unfold_env init_occ_env binds this_pkg = thisPackage dflags - tidy _ _ env [] = (env, []) - tidy mkIntegerId integerSDataCon env (b:bs) + tidy _ env [] = (env, []) + tidy cvt_integer env (b:bs) = let (env1, b') = tidyTopBind dflags this_pkg this_mod - mkIntegerId integerSDataCon unfold_env env b - (env2, bs') = tidy mkIntegerId integerSDataCon env1 bs + cvt_integer unfold_env env b + (env2, bs') = tidy cvt_integer env1 bs in (env2, b':bs') ------------------------ tidyTopBind :: DynFlags -> PackageKey -> Module - -> Id - -> Maybe DataCon + -> (Integer -> CoreExpr) -> UnfoldEnv -> TidyEnv -> CoreBind -> (TidyEnv, CoreBind) -tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env +tidyTopBind dflags this_pkg this_mod cvt_integer 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 dflags this_pkg this_mod - (mkIntegerId, integerSDataCon, subst1) (idArity bndr) rhs + caf_info = hasCafRefs dflags this_pkg this_mod (subst1, cvt_integer) (idArity bndr) rhs (bndr', rhs') = tidyTopPair dflags show_unfold tidy_env2 caf_info name' (bndr, rhs) subst2 = extendVarEnv subst1 bndr bndr' tidy_env2 = (occ_env, subst2) -tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env - (occ_env,subst1) (Rec prs) +tidyTopBind dflags this_pkg this_mod cvt_integer unfold_env + (occ_env, subst1) (Rec prs) = (tidy_env2, Rec prs') where prs' = [ tidyTopPair dflags show_unfold tidy_env2 caf_info name' (id,rhs) @@ -1161,8 +1160,8 @@ tidyTopBind dflags this_pkg this_mod mkIntegerId integerSDataCon unfold_env -- the group may refer indirectly to a CAF (because then, they all do). caf_info | or [ mayHaveCafRefs (hasCafRefs dflags this_pkg this_mod - (mkIntegerId, integerSDataCon, subst1) - (idArity bndr) rhs) + (subst1, cvt_integer) + (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs | otherwise = NoCafRefs @@ -1296,18 +1295,32 @@ hence the size of the SRTs) down, we could also look at the expression and decide whether it requires a small bounded amount of heap, so we can ignore it as a CAF. In these cases however, we would need to use an additional CAF list to keep track of non-collectable CAFs. + +Note [Disgusting computation of CafRefs] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We compute hasCafRefs here, because IdInfo is supposed to be finalised +after TidyPgm. But CorePrep does some transformations that affect CAF-hood. +So we have to *predict* the result here, which is revolting. + +In particular CorePrep expands Integer literals. So in the prediction code +here we resort to applying the same expansion (cvt_integer). Ugh! -} +type CafRefEnv = (VarEnv Id, Integer -> CoreExpr) + -- The env finds the Caf-ness of the Id + -- The Integer -> CoreExpr is the desugaring function for Integer literals + -- See Note [Disgusting computation of CafRefs] + hasCafRefs :: DynFlags -> PackageKey -> Module - -> (Id, Maybe DataCon, VarEnv Var) -> Arity -> CoreExpr + -> CafRefEnv -> Arity -> CoreExpr -> CafInfo -hasCafRefs dflags this_pkg this_mod p arity expr +hasCafRefs dflags this_pkg this_mod p@(_,cvt_integer) arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where - mentions_cafs = isFastTrue (cafRefsE dflags p expr) + mentions_cafs = isFastTrue (cafRefsE p expr) is_dynamic_name = isDllName dflags this_pkg this_mod - is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name expr) + is_caf = not (arity > 0 || rhsIsStatic (targetPlatform dflags) is_dynamic_name cvt_integer expr) -- NB. we pass in the arity of the expression, which is expected -- to be calculated by exprArity. This is because exprArity @@ -1315,35 +1328,34 @@ hasCafRefs dflags this_pkg this_mod p arity expr -- CorePrep later on, and we don't want to duplicate that -- knowledge in rhsIsStatic below. -cafRefsE :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> Expr a -> FastBool -cafRefsE _ p (Var id) = cafRefsV p id -cafRefsE dflags p (Lit lit) = cafRefsL dflags p lit -cafRefsE dflags p (App f a) = fastOr (cafRefsE dflags p f) (cafRefsE dflags p) a -cafRefsE dflags p (Lam _ e) = cafRefsE dflags p e -cafRefsE dflags p (Let b e) = fastOr (cafRefsEs dflags p (rhssOfBind b)) (cafRefsE dflags p) e -cafRefsE dflags p (Case e _bndr _ alts) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) (rhssOfAlts alts) -cafRefsE dflags p (Tick _n e) = cafRefsE dflags p e -cafRefsE dflags p (Cast e _co) = cafRefsE dflags p e -cafRefsE _ _ (Type _) = fastBool False -cafRefsE _ _ (Coercion _) = fastBool False - -cafRefsEs :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> [Expr a] -> FastBool -cafRefsEs _ _ [] = fastBool False -cafRefsEs dflags p (e:es) = fastOr (cafRefsE dflags p e) (cafRefsEs dflags p) es - -cafRefsL :: DynFlags -> (Id, Maybe DataCon, VarEnv Id) -> Literal -> FastBool +cafRefsE :: CafRefEnv -> Expr a -> FastBool +cafRefsE p (Var id) = cafRefsV p id +cafRefsE p (Lit lit) = cafRefsL p lit +cafRefsE p (App f a) = fastOr (cafRefsE p f) (cafRefsE p) a +cafRefsE p (Lam _ e) = cafRefsE p e +cafRefsE p (Let b e) = fastOr (cafRefsEs p (rhssOfBind b)) (cafRefsE p) e +cafRefsE p (Case e _bndr _ alts) = fastOr (cafRefsE p e) (cafRefsEs p) (rhssOfAlts alts) +cafRefsE p (Tick _n e) = cafRefsE p e +cafRefsE p (Cast e _co) = cafRefsE p e +cafRefsE _ (Type _) = fastBool False +cafRefsE _ (Coercion _) = fastBool False + +cafRefsEs :: CafRefEnv -> [Expr a] -> FastBool +cafRefsEs _ [] = fastBool False +cafRefsEs p (e:es) = fastOr (cafRefsE p e) (cafRefsEs p) es + +cafRefsL :: CafRefEnv -> Literal -> FastBool -- Don't forget that mk_integer id might have Caf refs! -- We first need to convert the Integer into its final form, to -- see whether mkInteger is used. -cafRefsL dflags p@(mk_integer, sdatacon, _) (LitInteger i _) - = cafRefsE dflags p (cvtLitInteger dflags mk_integer sdatacon i) -cafRefsL _ _ _ = fastBool False - -cafRefsV :: (Id, Maybe DataCon, VarEnv Id) -> Id -> FastBool -cafRefsV (_, _, p) id - | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) - | Just id' <- lookupVarEnv p id = fastBool (mayHaveCafRefs (idCafInfo id')) - | otherwise = fastBool False +cafRefsL p@(_, cvt_integer) (LitInteger i _) = cafRefsE p (cvt_integer i) +cafRefsL _ _ = fastBool False + +cafRefsV :: CafRefEnv -> Id -> FastBool +cafRefsV (subst, _) id + | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) + | Just id' <- lookupVarEnv subst id = fastBool (mayHaveCafRefs (idCafInfo id')) + | otherwise = fastBool False fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool -- hack for lazy-or over FastBool. diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T index 7b5e5f2dbe..cdb88380e2 100644 --- a/testsuite/tests/lib/integer/all.T +++ b/testsuite/tests/lib/integer/all.T @@ -3,8 +3,7 @@ test('integerConversions', normal, compile_and_run, ['']) # skip ghci as it doesn't support unboxed tuples test('integerGmpInternals', [reqlib('integer-gmp'), omit_ways('ghci')], compile_and_run, ['']) test('integerConstantFolding', - [ extra_clean(['integerConstantFolding.simpl']) - , when(compiler_debugged(), expect_broken(8525))], + extra_clean(['integerConstantFolding.simpl']), run_command, ['$MAKE -s --no-print-directory integerConstantFolding']) test('fromToInteger', |