[project @ 2003-04-10 14:44:18 by simonpj]

----------------------------------
       Fix a long-standing eta-reduction bug
	----------------------------------

Consider the stupid definition

	f = \x -> f x

We were erroneously eta-reducing this to

	f = f

(unsound because they'd be distinguishable by `seq`)

The reason was that simplLazyBind was exposing the arity of
a recursive function to its own RHS, when all it was really
trying to do was expose the *rules* for the function.

Easily fixed.   This fixes some

	"Bad eta expand"

warnings.  Good all round.  In particular, fixes rn006.

diff --git a/ghc/compiler/coreSyn/Subst.lhs b/ghc/compiler/coreSyn/Subst.lhs
index ca5db14..212e914 100644 (file)
--- a/ghc/compiler/coreSyn/Subst.lhs
+++ b/ghc/compiler/coreSyn/Subst.lhs
@@ -31,7 +31,7 @@ module Subst (
        substTyWith, substTy, substTheta, deShadowTy,
 
        -- Expression stuff
-       substExpr
+       substExpr, substRules
     ) where
 
 #include "HsVersions.h"

diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index d2b4dc9..2cb43e4 100644 (file)
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -24,6 +24,7 @@ import VarEnv
 import Id              ( Id, idType, idInfo, idArity, isDataConWorkId, 
                          setIdUnfolding, isDeadBinder,
                          idNewDemandInfo, setIdInfo,
+                         idSpecialisation, setIdSpecialisation,
                          setIdOccInfo, zapLamIdInfo, setOneShotLambda, 
                        )
 import OccName         ( encodeFS )
@@ -49,7 +50,7 @@ import CostCentre     ( currentCCS )
 import Type            ( isUnLiftedType, seqType, tyConAppArgs, funArgTy,
                          splitFunTy_maybe, splitFunTy, eqType
                        )
-import Subst           ( mkSubst, substTy, substExpr,
+import Subst           ( mkSubst, substTy, substExpr, substRules,
                          isInScope, lookupIdSubst, simplIdInfo
                        )
 import TysPrim         ( realWorldStatePrimTy )
@@ -451,24 +452,34 @@ simplLazyBind :: SimplEnv
              -> InExpr -> SimplEnv     -- The RHS and its environment
              -> SimplM (FloatsWith SimplEnv)
 
-simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
-  =    -- Substitute IdInfo on binder, in the light of earlier
-       -- substitutions in this very letrec, and extend the 
-       -- in-scope env, so that the IdInfo for this binder extends 
-       -- over the RHS for the binder itself.
+simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
+  =    -- Substitute the rules for this binder in the light
+       -- of earlier substitutions in this very letrec group,
+       -- add the substituted rules to the IdInfo, and 
+       -- extend the in-scope env, so that the IdInfo for this 
+       -- binder extends  over the RHS for the binder itself.
        --
        -- This is important.  Manuel found cases where he really, really
        -- wanted a RULE for a recursive function to apply in that function's
-       -- own right-hand side.
+       -- own right-hand side.
        --
        -- NB: does no harm for non-recursive bindings
+       --
+       -- NB2: just rules!  In particular, the arity of an Id is not visible
+       -- in its own RHS, else we eta-reduce
+       --      f = \x -> f x
+       -- to
+       --      f = f
+       -- which isn't sound.  And it makes the arity in f's IdInfo greater than
+       -- the manifest arity, which isn't good.
     let
-       bndr''            = bndr' `setIdInfo` simplIdInfo (getSubst env) (idInfo bndr)
-       env1              = modifyInScope env bndr'' bndr''
+       rules             = idSpecialisation bndr
+       bndr2             = bndr1 `setIdSpecialisation` substRules (getSubst env) rules
+       env1              = modifyInScope env bndr2 bndr2
        rhs_env           = setInScope rhs_se env1
        is_top_level      = isTopLevel top_lvl
        ok_float_unlifted = not is_top_level && isNonRec is_rec
-       rhs_cont          = mkStop (idType bndr') AnRhs
+       rhs_cont          = mkStop (idType bndr1) AnRhs
     in
        -- Simplify the RHS; note the mkStop, which tells 
        -- the simplifier that this is the RHS of a let.
@@ -477,7 +488,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
        -- If any of the floats can't be floated, give up now
        -- (The allLifted predicate says True for empty floats.)
     if (not ok_float_unlifted && not (allLifted floats)) then
-       completeLazyBind env1 top_lvl bndr bndr''
+       completeLazyBind env1 top_lvl bndr bndr2
                         (wrapFloats floats rhs1)
     else       
 
@@ -488,7 +499,7 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
        -- If the result is a PAP, float the floats out, else wrap them
        -- By this time it's already been ANF-ised (if necessary)
     if isEmptyFloats floats && isNilOL aux_binds then  -- Shortcut a common case
-       completeLazyBind env1 top_lvl bndr bndr'' rhs2
+       completeLazyBind env1 top_lvl bndr bndr2 rhs2
 
        -- We use exprIsTrivial here because we want to reveal lone variables.  
        -- E.g.  let { x = letrec { y = E } in y } in ...
@@ -516,10 +527,10 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se
        tick LetFloatFromLet                    `thenSmpl_` (
        addFloats env1 floats                   $ \ env2 ->
        addAtomicBinds env2 (fromOL aux_binds)  $ \ env3 ->
-       completeLazyBind env3 top_lvl bndr bndr'' rhs2)
+       completeLazyBind env3 top_lvl bndr bndr2 rhs2)
 
     else
-       completeLazyBind env1 top_lvl bndr bndr'' (wrapFloats floats rhs1)
+       completeLazyBind env1 top_lvl bndr bndr2 (wrapFloats floats rhs1)
 
 #ifdef DEBUG
 demanded_float (NonRec b r) = isStrictDmd (idNewDemandInfo b) && not (isUnLiftedType (idType b))
@@ -692,8 +703,8 @@ simplExprF env (Case scrut bndr alts) cont
 
 simplExprF env (Let (Rec pairs) body) cont
   = simplRecBndrs env (map fst pairs)          `thenSmpl` \ (env, bndrs') -> 
-       -- NB: bndrs' don't have unfoldings or spec-envs
-       -- We add them as we go down, using simplPrags
+       -- NB: bndrs' don't have unfoldings or rules
+       -- We add them as we go down
 
     simplRecBind env NotTopLevel pairs bndrs'  `thenSmpl` \ (floats, env) ->
     addFloats env floats                       $ \ env ->