[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.

diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index 03258d9..88c4c70 100644 (file)
--- 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 (file)
--- 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.
        --