[project @ 1998-05-19 10:59:59 by simonm]

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

diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 2d37a9d..6d2f9cd 100644 (file)
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -20,9 +20,10 @@ module OccurAnal (
 import BinderInfo
 import CmdLineOpts     ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
 import CoreSyn
+import CoreUtils       ( idSpecVars )
 import Digraph         ( stronglyConnCompR, SCC(..) )
 import Id              ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
-                         omitIfaceSigForId,
+                         omitIfaceSigForId, isSpecPragmaId, getIdSpecialisation,
                          idType, idUnique, Id,
                          emptyIdSet, unionIdSets, mkIdSet,
                          elementOfIdSet,
@@ -32,7 +33,7 @@ import Id             ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
                          delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv, 
                          mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
                        )
-import Specialise       ( idSpecVars )
+import SpecEnv         ( isEmptySpecEnv )
 import Name            ( isExported, isLocallyDefined )
 import Type            ( splitFunTy_maybe, splitForAllTys )
 import Maybes          ( maybeToBool )
@@ -159,6 +160,11 @@ occAnalTop :: OccEnv                       -- What's in scope
 occAnalTop env [] = (emptyDetails, nullIdEnv, [])
 
 -- Special case for eliminating indirections
+--   Note: it's a shortcoming that this only works for
+--        non-recursive bindings.  Elminating indirections
+--        makes perfect sense for recursive bindings too, but
+--        it's more complicated to implement, so I haven't done so
+
 occAnalTop env (NonRec exported_id (Var local_id) : binds)
   | isExported exported_id &&          -- Only if this is exported
 
@@ -454,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
@@ -554,16 +563,17 @@ If we aren't careful we duplicate the (expensive x) call!
 Constructors are rather like lambdas in this way.
 
 \begin{code}
-occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args), 
-                             Con con args)
+occAnal env (Con con args)
+  = (mapIdEnv markDangerousToDup (occAnalArgs env args), 
+     Con con args)
 
-occAnal env (SCC cc body)
-  = (mapIdEnv markInsideSCC usage, SCC cc body')
+occAnal env (Note note@(SCC cc) body)
+  = (mapIdEnv markInsideSCC usage, Note note body')
   where
     (usage, body') = occAnal env body
 
-occAnal env (Coerce c ty body)
-  = (usage, Coerce c ty body')
+occAnal env (Note note body)
+  = (usage, Note note body')
   where
     (usage, body') = occAnal env body
 
@@ -789,7 +799,7 @@ tagBinder usage binder =
 
 
 usage_of usage binder
-  | isExported binder
+  | isExported binder || isSpecPragmaId binder
   = noBinderInfo       -- Visible-elsewhere things count as many
   | otherwise
   = case (lookupIdEnv usage binder) of