From c9c016973e8b1cf996d0b87f24204b70622dc97f Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 21 Nov 2002 14:59:52 +0000 Subject: [PATCH] [project @ 2002-11-21 14:59:51 by simonpj] ------------------------------- Better notion of what a 'value' is Slightly better eta reduction ------------------------------- 1. At various places we watch out for "values"; the predicate exprIsValue detects them. It was stupidly treating nullary constructors as non-values which is exceptionally stupid. This (performance) bug has been there for ages. There's an exactly similar bug in SimplUtils.interestingArg, which looks for an interesting argument to trigger an inlining. 2. The eta reduction in SimplUtils.tryEtaReduce would only eta reduce if that left us with a variable. That led to slightly tiresome thing like :DMonad (/\a b -> foo @ s @ a @ b) ... where this would be neater :DMonad (foo @ s) The fix is easy, and there's a little less code too. --- ghc/compiler/coreSyn/CoreUtils.lhs | 57 +++++++++++++++++++-------------- ghc/compiler/simplCore/SimplUtils.lhs | 19 +++++++---- 2 files changed, 45 insertions(+), 31 deletions(-) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 03258d9..88c4c70 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -576,33 +576,42 @@ type must be ok-for-speculation (or trivial). \begin{code} exprIsValue :: CoreExpr -> Bool -- True => Value-lambda, constructor, PAP -exprIsValue (Type ty) = True -- Types are honorary Values; we don't mind - -- copying them -exprIsValue (Lit l) = True -exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e -exprIsValue (Note _ e) = exprIsValue e -exprIsValue (Var v) = idArity v > 0 || isEvaldUnfolding (idUnfolding v) - -- The idArity case catches data cons and primops that - -- don't have unfoldings +exprIsValue (Var v) -- NB: There are no value args at this point + = isDataConId v -- Catches nullary constructors, + -- so that [] and () are values, for example + || idArity v > 0 -- Catches (e.g.) primops that don't have unfoldings + || isEvaldUnfolding (idUnfolding v) + -- Check the thing's unfolding; it might be bound to a value -- A worry: what if an Id's unfolding is just itself: -- then we could get an infinite loop... -exprIsValue other_expr - | (Var fun, args) <- collectArgs other_expr, - isDataConId fun || valArgCount args < idArity fun - = check (idType fun) args - | otherwise - = False + +exprIsValue (Lit l) = True +exprIsValue (Type ty) = True -- Types are honorary Values; + -- we don't mind copying them +exprIsValue (Lam b e) = isRuntimeVar b || exprIsValue e +exprIsValue (Note _ e) = exprIsValue e +exprIsValue (App e (Type _)) = exprIsValue e +exprIsValue (App e a) = app_is_value e [a] +exprIsValue other = False + +-- There is at least one value argument +app_is_value (Var fun) args + | isDataConId fun -- Constructor apps are values + || idArity fun > valArgCount args -- Under-applied function + = check_args (idType fun) args +app_is_value (App f a) as = app_is_value f (a:as) +app_is_value other as = False + + -- 'check_args' checks that unlifted-type args + -- are in fact guaranteed non-divergent +check_args fun_ty [] = True +check_args fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of + Just (_, ty) -> check_args ty args +check_args fun_ty (arg : args) + | isUnLiftedType arg_ty = exprOkForSpeculation arg + | otherwise = check_args res_ty args where - -- 'check' checks that unlifted-type args are in - -- fact guaranteed non-divergent - check fun_ty [] = True - check fun_ty (Type _ : args) = case splitForAllTy_maybe fun_ty of - Just (_, ty) -> check ty args - check fun_ty (arg : args) - | isUnLiftedType arg_ty = exprOkForSpeculation arg - | otherwise = check res_ty args - where - (arg_ty, res_ty) = splitFunTy fun_ty + (arg_ty, res_ty) = splitFunTy fun_ty \end{code} \begin{code} diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 1d9b987..f6e4b66 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -25,12 +25,13 @@ import CmdLineOpts ( SimplifierSwitch(..), opt_SimplCaseMerge, opt_UF_UpdateInPlace ) import CoreSyn -import CoreUtils ( cheapEqExpr, exprType, +import CoreFVs ( exprFreeVars ) +import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2, findDefault, exprOkForSpeculation, exprIsValue ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) -import Id ( Id, idType, idInfo, +import Id ( Id, idType, idInfo, isDataConId, mkSysLocal, isDeadBinder, idNewDemandInfo, idUnfolding, idNewStrictness ) @@ -44,6 +45,7 @@ import OccName ( EncodedFS ) import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys ) import Var ( mkSysTyVar, tyVarKind ) +import VarSet import Util ( lengthExceeds, mapAccumL ) import Outputable \end{code} @@ -273,6 +275,9 @@ interestingArg :: OutExpr -> Bool interestingArg (Var v) = hasSomeUnfolding (idUnfolding v) -- Was: isValueUnfolding (idUnfolding v') -- But that seems over-pessimistic + || isDataConId v + -- This accounts for an argument like + -- () or [], which is definitely interesting interestingArg (Type _) = False interestingArg (App fn (Type _)) = interestingArg fn interestingArg (Note _ a) = interestingArg a @@ -540,17 +545,17 @@ tryEtaReduce bndrs body -- efficient here: -- (a) we already have the binders -- (b) we can do the triviality test before computing the free vars - -- [in fact I take the simple path and look for just a variable] = go (reverse bndrs) body where go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round - go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success! + go [] fun | ok_fun fun = Just fun -- Success! go _ _ = Nothing -- Failure! - ok_fun fun = not (fun `elem` bndrs) && - (isEvaldUnfolding (idUnfolding fun) || all ok_lam bndrs) + ok_fun fun = exprIsTrivial fun + && not (any (`elemVarSet` (exprFreeVars fun)) bndrs) + && (exprIsValue fun || all ok_lam bndrs) ok_lam v = isTyVar v || isDictTy (idType v) - -- The isEvaldUnfolding is because eta reduction is not + -- The exprIsValue is because eta reduction is not -- valid in general: \x. bot /= bot -- So we need to be sure that the "fun" is a value. -- -- 1.7.10.4