[project @ 1997-09-09 18:04:55 by sof]

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

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 5ae771e..5796cd4 100644 (file)
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -18,7 +18,6 @@ module OccurAnal (
     ) where
 
 IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(IdLoop)        -- paranoia
 IMPORT_1_3(List(partition))
 
 import BinderInfo
@@ -26,8 +25,7 @@ import CmdLineOpts    ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
 import CoreSyn
 import Digraph         ( stronglyConnComp, stronglyConnCompR, SCC(..) )
 import Id              ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
-                         idType, idUnique,
-                         isConstMethodId,
+                         idType, idUnique, SYN_IE(Id),
                          emptyIdSet, unionIdSets, mkIdSet,
                          unitIdSet, elementOfIdSet,
                          addOneToIdSet, SYN_IE(IdSet),
@@ -39,9 +37,8 @@ import Id             ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
 import Name            ( isExported, isLocallyDefined )
 import Type            ( getFunTy_maybe, splitForAllTy )
 import Maybes          ( maybeToBool )
-import Outputable      ( Outputable(..){-instance * (,) -} )
+import Outputable      ( PprStyle(..), Outputable(..){-instance * (,) -} )
 import PprCore
-import PprStyle                ( PprStyle(..) )
 import PprType         ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
 import Pretty          ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
 import TyVar           ( GenTyVar{-instance Eq-} )
@@ -114,7 +111,8 @@ keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
 
 keepBecauseConjurable :: OccEnv -> Id -> Bool
 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
-  = keep_conjurable && isConstMethodId binder
+  = False
+    {- keep_conjurable && isConstMethodId binder -}
 
 type UsageDetails = IdEnv BinderInfo   -- A finite map from ids to their usage
 
@@ -165,27 +163,29 @@ tagBinder usage binder =
    usage'  = usage `delOneFromIdEnv` binder
    us      = usage_of usage binder 
    cont =
-    if isNullIdEnv usage' then  -- bogus test to force evaluation.
+    if isNullIdEnv usage' then  -- Bogus test to force evaluation.
        (usage', (binder, us))
     else
        (usage', (binder, us))
  in
- case us of { DeadCode -> cont; _ -> cont }
-
---   (binder, usage_of usage binder)
+ if isDeadOcc us then          -- Ditto 
+       cont
+ else 
+       cont
 
 
 usage_of usage binder
-  | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
+  | isExported binder = noBinderInfo   -- Visible-elsewhere things count as many
   | otherwise
   = case (lookupIdEnv usage binder) of
-      Nothing   -> DeadCode
+      Nothing   -> deadOccurrence
       Just info -> info
 
 isNeeded env usage binder
-  = case (usage_of usage binder) of
-      DeadCode  -> keepUnusedBinding env binder        -- Maybe keep it anyway
-      other     -> True
+  = if isDeadOcc (usage_of usage binder) then
+       keepUnusedBinding env binder    -- Maybe keep it anyway
+    else
+       True
 \end{code}
 
 
@@ -427,10 +427,32 @@ Here's a case that bit me:
        ...a...a...a....
 
 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
-(The first binding was a var-rhs; the second was a one-occ.)  So the simplifier looped.
+
 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
 Perhaps something cleverer would suffice.
 
+You might think that you can prevent non-termination simply by making
+sure that we simplify a recursive binding's RHS in an environment that
+simply clones the recursive Id.  But no.  Consider
+
+               letrec f = \x -> let z = f x' in ...
+
+               in
+               let n = f y
+               in
+               case n of { ... }
+
+We bind n to its *simplified* RHS, we then *re-simplify* it when
+we inline n.  Then we may well inline f; and then the same thing
+happens with z!
+
+I don't think it's possible to prevent non-termination by environment
+manipulation in this way.  Apart from anything else, successive
+iterations of the simplifier may unroll recursive loops in cases like
+that above.  The idea of beaking every recursive loop with an
+IMustNotBeINLINEd pragma is much much better.
+
+
 \begin{code}
 reOrderRec
        :: OccEnv
@@ -472,18 +494,10 @@ reOrderRec env (CyclicSCC binds)
     bad_choice ((bndr, occ_info), rhs)
        =    var_rhs rhs                -- Dont pick var RHS
          || inlineMe env bndr          -- Dont pick INLINE thing
-         || one_occ occ_info           -- Dont pick single-occ thing
+         || isOneFunOcc occ_info       -- Dont pick single-occ thing
          || not_fun_ty (idType bndr)   -- Dont pick data-ty thing
 
-    not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
-                 where
-                   (_, rho_ty) = splitForAllTy ty
-
-       -- A variable RHS
-    var_rhs (Var v)   = True
-    var_rhs other_rhs = False
-
-       -- One textual occurrence, whether inside lambda or whatever
+       -- 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
        -- to inline the thing on this round it might be better to pick
        -- this one as the loop breaker.  Real example (the Enum Ordering instance
@@ -496,8 +510,13 @@ reOrderRec env (CyclicSCC binds)
        -- On the other hand we *could* simplify those case expressions if
        -- we didn't stupidly choose d as the loop breaker.
 
-    one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg
-    one_occ other_bind                 = False
+    not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
+                 where
+                   (_, rho_ty) = splitForAllTy ty
+
+       -- A variable RHS
+    var_rhs (Var v)   = True
+    var_rhs other_rhs = False
 \end{code}
 
 @occAnalRhs@ deals with the question of bindings where the Id is marked