[project @ 1998-04-29 09:30:16 by simonpj]

Alleged fix to SpecEnv muddle for recursive bindings

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 74a36af..791eee6 100644 (file)
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -22,7 +22,7 @@ import CmdLineOpts    ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
 import CoreSyn
 import Digraph         ( stronglyConnCompR, SCC(..) )
 import Id              ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
-                         omitIfaceSigForId, isSpecPragmaId,
+                         omitIfaceSigForId, isSpecPragmaId, getIdSpecialisation,
                          idType, idUnique, Id,
                          emptyIdSet, unionIdSets, mkIdSet,
                          elementOfIdSet,
@@ -33,6 +33,7 @@ import Id             ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
                          mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
                        )
 import Specialise       ( idSpecVars )
+import SpecEnv         ( isEmptySpecEnv )
 import Name            ( isExported, isLocallyDefined )
 import Type            ( splitFunTy_maybe, splitForAllTys )
 import Maybes          ( maybeToBool )
@@ -459,6 +460,9 @@ reOrderRec env (CyclicSCC binds)
          || inlineMe env bndr          -- Dont pick INLINE thing
          || isOneFunOcc occ_info       -- Dont pick single-occ thing
          || not_fun_ty (idType bndr)   -- Dont pick data-ty thing
+         || not (isEmptySpecEnv (getIdSpecialisation bndr))
+               -- Avoid things with a SpecEnv; we'd like
+               -- to take advantage of the SpecEnv in the subsuequent bindings
 
        -- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
        -- We stick to just FunOccs because if we're not going to be able

diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index 95bd9c8..3c511f4 100644 (file)
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -413,15 +413,15 @@ lookupUnfolding env id
        Just (_,_,info) -> info
        Nothing         -> NoUnfolding
 
-modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)
-                -> (OutId, BinderInfo, Unfolding) 
-                -> (OutId, BinderInfo, Unfolding)
-modifyOutEnvItem (id, occ, info1) (_, _, info2)
-  = case (info1, info2) of
-               (OtherLit ls1, OtherLit ls2) -> (id,occ, OtherLit (ls1++ls2))
-               (OtherCon cs1, OtherCon cs2) -> (id,occ, OtherCon (cs1++cs2))
-               (_,            NoUnfolding)  -> (id,occ, info1)
-               other                        -> (id,occ, info2)
+modifyOutEnvItem :: (OutId, BinderInfo, Unfolding)     -- Existing
+                -> (OutId, BinderInfo, Unfolding)      -- New
+                -> (OutId, BinderInfo, Unfolding)      
+modifyOutEnvItem (_, _, info1) (id, occ, info2)
+  = (id, occ, case (info1, info2) of
+               (OtherLit ls1, OtherLit ls2) -> OtherLit (ls1++ls2)
+               (OtherCon cs1, OtherCon cs2) -> OtherCon (cs1++cs2)
+               (_,            NoUnfolding)  -> info1
+               other                        -> info2)
 \end{code}