[project @ 2000-09-14 13:46:39 by simonpj]

[ghc-hetmet.git] / ghc / compiler / simplCore / SimplUtils.lhs

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 235593c..29f9a6a 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -19,17 +19,18 @@ module SimplUtils (
 #include "HsVersions.h"
 
 import CmdLineOpts     ( switchIsOn, SimplifierSwitch(..),
-                         opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict
+                         opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge, opt_DictsStrict,
+                         opt_UF_UpdateInPlace
                        )
 import CoreSyn
 import CoreUnfold      ( isValueUnfolding )
 import CoreUtils       ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, exprEtaExpandArity, bindNonRec )
-import Subst           ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, lookupIdSubst )
+import Subst           ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
 import Id              ( Id, idType, isId, idName, 
                          idOccInfo, idUnfolding, idStrictness,
                          mkId, idInfo
                        )
-import IdInfo          ( StrictnessInfo(..), arityLowerBound, setOccInfo, vanillaIdInfo )
+import IdInfo          ( StrictnessInfo(..), ArityInfo, atLeastArity, setOccInfo, vanillaIdInfo )
 import Maybes          ( maybeToBool, catMaybes )
 import Name            ( isLocalName, setNameUnique )
 import Demand          ( Demand, isStrict, wwLazy, wwLazy )
@@ -265,27 +266,24 @@ interestingArg :: InScopeSet -> InExpr -> SubstEnv -> Bool
        -- (i.e. they are probably lambda bound): f x y z
        -- There is little point in inlining f here.
 interestingArg in_scope arg subst
-  = analyse arg
+  = analyse (substExpr (mkSubst in_scope subst) arg)
+       -- 'analyse' only looks at the top part of the result
+       -- and substExpr is lazy, so this isn't nearly as brutal
+       -- as it looks.
   where
-    analyse (Var v)
-       = case lookupIdSubst (mkSubst in_scope subst) v of
-           ContEx subst arg -> interestingArg in_scope arg subst
-           DoneEx arg       -> analyse arg
-           DoneId v' _      -> hasSomeUnfolding (idUnfolding v')
+    analyse (Var v)          = hasSomeUnfolding (idUnfolding v)
                                -- Was: isValueUnfolding (idUnfolding v')
                                -- But that seems over-pessimistic
-
-       -- NB: it's too pessimistic to return False for ContEx/DoneEx
-       -- Consider     let x = 3 in f x
-       -- The substitution will contain (x -> ContEx 3)
-       -- It's also too optimistic to return True for the ContEx/DoneEx case
-       -- Consider (\x. f x y) y
-       -- The substitution will contain (x -> ContEx y).
-
     analyse (Type _)         = False
     analyse (App fn (Type _)) = analyse fn
     analyse (Note _ a)       = analyse a
     analyse other            = True
+       -- Consider     let x = 3 in f x
+       -- The substitution will contain (x -> ContEx 3), and we want to
+       -- to say that x is an interesting argument.
+       -- But consider also (\x. f x y) y
+       -- The substitution will contain (x -> ContEx y), and we want to say
+       -- that x is not interesting (assuming y has no unfolding)
 \end{code}
 
 Comment about interestingCallContext
@@ -402,7 +400,10 @@ canUpdateInPlace :: Type -> Bool
 
 -- Note the repType: we want to look through newtypes for this purpose
 
-canUpdateInPlace ty = case splitTyConApp_maybe (repType ty) of {
+canUpdateInPlace ty 
+  | not opt_UF_UpdateInPlace = False
+  | otherwise
+  = case splitTyConApp_maybe (repType ty) of {
                        Nothing         -> False ;
                        Just (tycon, _) -> 
 
@@ -475,7 +476,7 @@ Try (a) eta expansion
 
 \begin{code}
 transformRhs :: OutExpr 
-            -> (Arity -> OutExpr -> SimplM (OutStuff a))
+            -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
             -> SimplM (OutStuff a)
 
 transformRhs rhs thing_inside 
@@ -692,7 +693,7 @@ what the final test in the first equation is for.
 
 \begin{code}
 tryEtaExpansion :: OutExpr 
-               -> (Arity -> OutExpr -> SimplM (OutStuff a))
+               -> (ArityInfo -> OutExpr -> SimplM (OutStuff a))
                -> SimplM (OutStuff a)
 tryEtaExpansion rhs thing_inside
   |  not opt_SimplDoLambdaEtaExpansion
@@ -730,8 +731,8 @@ tryEtaExpansion rhs thing_inside
 
     fun_arity       = exprEtaExpandArity fun
 
-    final_arity | all_trivial_args = x_arity + extra_args_wanted
-               | otherwise        = x_arity
+    final_arity | all_trivial_args = atLeastArity (x_arity + extra_args_wanted)
+               | otherwise        = atLeastArity x_arity
        -- Arity can be more than the number of lambdas
        -- because of coerces. E.g.  \x -> coerce t (\y -> e) 
        -- will have arity at least 2