[project @ 2001-04-12 21:29:43 by lewie]

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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 387cbd8..501dd60 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -5,7 +5,7 @@
 
 \begin{code}
 module SimplUtils (
-       simplBinder, simplBinders, simplIds,
+       simplBinder, simplBinders, simplRecIds, simplLetId,
        tryRhsTyLam, tryEtaExpansion,
        mkCase,
 
@@ -25,12 +25,13 @@ import CmdLineOpts  ( switchIsOn, SimplifierSwitch(..),
 import CoreSyn
 import CoreUtils       ( exprIsTrivial, cheapEqExpr, exprType, exprIsCheap, 
                          etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce,
-                         findDefault, findAlt
+                         findDefault
                        )
-import Subst           ( InScopeSet, mkSubst, substBndrs, substBndr, substIds, substExpr )
+import Subst           ( InScopeSet, mkSubst, substExpr )
+import qualified Subst ( simplBndrs, simplBndr, simplLetId )
 import Id              ( idType, idName, 
                          idUnfolding, idStrictness,
-                         mkVanillaId, idInfo
+                         mkLocalId, idInfo
                        )
 import IdInfo          ( StrictnessInfo(..) )
 import Maybes          ( maybeToBool, catMaybes )
@@ -45,7 +46,7 @@ import Type           ( Type, mkForAllTys, seqType, repType,
 import TyCon           ( tyConDataConsIfAvailable )
 import DataCon         ( dataConRepArity )
 import VarEnv          ( SubstEnv )
-import Util            ( lengthExceeds )
+import Util            ( lengthExceeds, mapAccumL )
 import Outputable
 \end{code}
 
@@ -368,7 +369,10 @@ interestingCallContext some_args some_val_args cont
   where
     interesting (InlinePlease _)       = True
     interesting (Select _ _ _ _ _)     = some_args
-    interesting (ApplyTo _ _ _ _)      = some_args     -- Can happen if we have (coerce t (f x)) y
+    interesting (ApplyTo _ _ _ _)      = True  -- Can happen if we have (coerce t (f x)) y
+                                               -- Perhaps True is a bit over-keen, but I've
+                                               -- seen (coerce f) x, where f has an INLINE prag,
+                                               -- So we have to give some motivaiton for inlining it
     interesting (ArgOf _ _ _)         = some_val_args
     interesting (Stop ty upd_in_place) = some_val_args && upd_in_place
     interesting (CoerceIt _ cont)      = interesting cont
@@ -428,7 +432,7 @@ simplBinders :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
 simplBinders bndrs thing_inside
   = getSubst           `thenSmpl` \ subst ->
     let
-       (subst', bndrs') = substBndrs subst bndrs
+       (subst', bndrs') = Subst.simplBndrs subst bndrs
     in
     seqBndrs bndrs'    `seq`
     setSubst subst' (thing_inside bndrs')
@@ -437,23 +441,29 @@ simplBinder :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
 simplBinder bndr thing_inside
   = getSubst           `thenSmpl` \ subst ->
     let
-       (subst', bndr') = substBndr subst bndr
+       (subst', bndr') = Subst.simplBndr subst bndr
     in
     seqBndr bndr'      `seq`
     setSubst subst' (thing_inside bndr')
 
 
--- Same semantics as simplBinders, but a little less 
--- plumbing and hence a little more efficient.
--- Maybe not worth the candle?
-simplIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
-simplIds ids thing_inside
+simplRecIds :: [InBinder] -> ([OutBinder] -> SimplM a) -> SimplM a
+simplRecIds ids thing_inside
   = getSubst           `thenSmpl` \ subst ->
     let
-       (subst', bndrs') = substIds subst ids
+       (subst', ids') = mapAccumL Subst.simplLetId subst ids
     in
-    seqBndrs bndrs'    `seq`
-    setSubst subst' (thing_inside bndrs')
+    seqBndrs ids'      `seq`
+    setSubst subst' (thing_inside ids')
+
+simplLetId :: InBinder -> (OutBinder -> SimplM a) -> SimplM a
+simplLetId id thing_inside
+  = getSubst           `thenSmpl` \ subst ->
+    let
+       (subst', id') = Subst.simplLetId subst id
+    in
+    seqBndr id'        `seq`
+    setSubst subst' (thing_inside id')
 
 seqBndrs [] = ()
 seqBndrs (b:bs) = seqBndr b `seq` seqBndrs bs
@@ -608,7 +618,7 @@ tryRhsTyLam rhs                     -- Only does something if there's a let
        let
            poly_name = setNameUnique (idName var) uniq         -- Keep same name
            poly_ty   = mkForAllTys tyvars_here (idType var)    -- But new type of course
-           poly_id   = mkVanillaId poly_name poly_ty 
+           poly_id   = mkLocalId poly_name poly_ty 
 
                -- In the olden days, it was crucial to copy the occInfo of the original var, 
                -- because we were looking at occurrence-analysed but as yet unsimplified code!
@@ -680,6 +690,11 @@ There is no point in looking for a combination of the two, because
 that would leave use with some lets sandwiched between lambdas; that's
 what the final test in the first equation is for.
 
+In Case 1, we may have to sandwich some coerces between the lambdas
+to make the types work.   exprEtaExpandArity looks through coerces
+when computing arity; and etaExpand adds the coerces as necessary when
+actually computing the expansion.
+
 \begin{code}
 tryEtaExpansion :: OutExpr -> OutType -> SimplM ([OutBind], OutExpr)
 tryEtaExpansion rhs rhs_ty