[project @ 2000-10-25 13:51:50 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 85c1c4d..05c989c 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -19,32 +19,30 @@ 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, substExpr )
-import Id              ( Id, idType, isId, idName, 
-                         idOccInfo, idUnfolding, idStrictness,
+import Id              ( idType, idName, 
+                         idUnfolding, idStrictness,
                          mkId, idInfo
                        )
-import IdInfo          ( StrictnessInfo(..), arityLowerBound, setOccInfo, vanillaIdInfo )
+import IdInfo          ( StrictnessInfo(..), ArityInfo, atLeastArity, vanillaIdInfo )
 import Maybes          ( maybeToBool, catMaybes )
-import Name            ( isLocalName, setNameUnique )
-import Demand          ( Demand, isStrict, wwLazy, wwLazy )
+import Name            ( setNameUnique )
+import Demand          ( isStrict )
 import SimplMonad
-import Type            ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType, repType,
-                         splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys,
-                         isDictTy, isDataType, applyTy, splitFunTy, isUnLiftedType,
+import Type            ( Type, mkForAllTys, seqType, repType,
+                         splitTyConApp_maybe, mkTyVarTys, splitFunTys, 
+                         isDictTy, isDataType, isUnLiftedType,
                          splitRepFunTys
                        )
 import TyCon           ( tyConDataConsIfAvailable )
 import DataCon         ( dataConRepArity )
-import VarSet
-import VarEnv          ( SubstEnv, SubstResult(..) )
+import VarEnv          ( SubstEnv )
 import Util            ( lengthExceeds )
-import BasicTypes      ( Arity )
 import Outputable
 \end{code}
 
@@ -399,7 +397,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, _) -> 
 
@@ -472,7 +473,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 
@@ -689,7 +690,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
@@ -727,8 +728,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