[project @ 1999-07-14 14:40:20 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 4ef7937..a5877bd 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -18,18 +18,18 @@ import BinderInfo
 import CmdLineOpts     ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
 import CoreSyn
 import CoreFVs         ( exprFreeVars )
-import CoreUtils       ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap )
+import CoreUtils       ( exprIsTrivial, cheapEqExpr, coreExprType, exprIsCheap, exprGenerousArity )
 import Subst           ( substBndrs, substBndr, substIds )
 import Id              ( Id, idType, getIdArity, isId, idName,
                          getInlinePragma, setInlinePragma,
-                         getIdDemandInfo, mkId
+                         getIdDemandInfo, mkId, idInfo
                        )
 import IdInfo          ( arityLowerBound, InlinePragInfo(..), setInlinePragInfo, vanillaIdInfo )
 import Maybes          ( maybeToBool, catMaybes )
 import Const           ( Con(..) )
 import Name            ( isLocalName, setNameUnique )
 import SimplMonad
-import Type            ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys,
+import Type            ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
                          splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
                        )
 import TysPrim         ( statePrimTyCon )
@@ -54,8 +54,8 @@ simplBinders bndrs thing_inside
     let
        (subst', bndrs') = substBndrs subst bndrs
     in
-    setSubst subst'    $
-    thing_inside bndrs'
+    seqBndrs bndrs'    `seq`
+    setSubst subst' (thing_inside bndrs')
 
 simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 simplBinder bndr thing_inside
@@ -63,8 +63,8 @@ simplBinder bndr thing_inside
     let
        (subst', bndr') = substBndr subst bndr
     in
-    setSubst subst'    $
-    thing_inside bndr'
+    seqBndr bndr'      `seq`
+    setSubst subst' (thing_inside bndr')
 
 
 -- Same semantics as simplBinders, but a little less 
@@ -76,8 +76,16 @@ simplIds ids thing_inside
     let
        (subst', bndrs') = substIds subst ids
     in
-    setSubst subst'    $
-    thing_inside bndrs'
+    seqBndrs bndrs'    `seq`
+    setSubst subst' (thing_inside bndrs')
+
+seqBndrs [] = ()
+seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
+
+seqBndr b | isTyVar b = b `seq` ()
+         | otherwise = seqType (idType b)      `seq`
+                       idInfo b                `seq`
+                       ()
 \end{code}
 
 
@@ -287,7 +295,7 @@ where (in both cases) N is a NORMAL FORM (i.e. no redexes anywhere)
 wanting a suitable number of extra args.
 
 NB: the Ei may have unlifted type, but the simplifier (which is applied
-to the result) deals OK with this).
+to the result) deals OK with this.
 
 There is no point in looking for a combination of the two, 
 because that would leave use with some lets sandwiched between lambdas;
@@ -314,9 +322,7 @@ tryEtaExpansion rhs
     (x_bndrs, body) = collectValBinders rhs
     (fun, args)            = collectArgs body
     trivial_args    = map exprIsTrivial args
-    fun_arity      = case fun of
-                       Var v -> arityLowerBound (getIdArity v)
-                       other -> 0
+    fun_arity      = exprGenerousArity fun
 
     bind_z_arg (arg, trivial_arg) 
        | trivial_arg = returnSmpl (Nothing, arg)
@@ -335,7 +341,7 @@ tryEtaExpansion rhs
     y_tys  = take no_extras_wanted potential_extra_arg_tys
        
     no_extras_wanted :: Int
-    no_extras_wanted = 
+    no_extras_wanted = 0 `max`
 
        -- We used to expand the arity to the previous arity fo the
        -- function; but this is pretty dangerous.  Consdier
@@ -349,8 +355,9 @@ tryEtaExpansion rhs
        -- (bndr_arity - no_of_xs)              `max`
 
        -- See if the body could obviously do with more args
-       (fun_arity - valArgCount args)  `max`
+       (fun_arity - valArgCount args)
 
+-- This case is now deal with by exprGenerousArity
        -- Finally, see if it's a state transformer, and xs is non-null
        -- (so it's also a function not a thunk) in which
        -- case we eta-expand on principle! This can waste work,
@@ -360,11 +367,11 @@ tryEtaExpansion rhs
        --      \ x -> let {..} in \ s -> f (...) s
        -- AND f RETURNED A FUNCTION.  That is, 's' wasn't the only
        -- potential extra arg.
-       case (x_bndrs, potential_extra_arg_tys) of
-           (_:_, ty:_)  -> case splitTyConApp_maybe ty of
-                                 Just (tycon,_) | tycon == statePrimTyCon -> 1
-                                 other                                    -> 0
-           other -> 0
+--     case (x_bndrs, potential_extra_arg_tys) of
+--         (_:_, ty:_)  -> case splitTyConApp_maybe ty of
+--                               Just (tycon,_) | tycon == statePrimTyCon -> 1
+--                               other                                    -> 0
+--         other -> 0
 \end{code}