[project @ 2002-03-04 17:01:26 by simonmar]

[ghc-hetmet.git] / ghc / compiler / coreSyn / CoreTidy.lhs

diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs
index b3010f8..b0dfbd3 100644 (file)
--- a/ghc/compiler/coreSyn/CoreTidy.lhs
+++ b/ghc/compiler/coreSyn/CoreTidy.lhs
@@ -14,7 +14,7 @@ module CoreTidy (
 import CmdLineOpts     ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
 import CoreSyn
 import CoreUnfold      ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
-import CoreFVs         ( ruleSomeFreeVars, exprSomeFreeVars )
+import CoreFVs         ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars )
 import PprCore         ( pprIdCoreRule )
 import CoreLint                ( showPass, endPass )
 import CoreUtils       ( exprArity )
@@ -137,6 +137,11 @@ tidyCorePgm dflags mod pcs cg_info_env
 
        ; let ext_ids   = findExternalSet   binds_in orphans_in
        ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
+               -- findExternalRules filters ext_rules to avoid binders that 
+               -- aren't externally visible; but the externally-visible binders 
+               -- are computed (by findExternalSet) assuming that all orphan
+               -- rules are exported.  So in fact we may export more than we
+               -- need.  (It's a sort of mutual recursion.)
 
        -- We also make sure to avoid any exported binders.  Consider
        --      f{-u1-} = 1     -- Local decl
@@ -248,17 +253,25 @@ findExternalRules :: [CoreBind]
 findExternalRules binds orphan_rules ext_ids
   | opt_OmitInterfacePragmas = []
   | otherwise
-  = orphan_rules ++ local_rules
+  = filter needed_rule (orphan_rules ++ local_rules)
   where
     local_rules  = [ (id, rule)
                   | id <- bindersOfBinds binds,
                     id `elemVarEnv` ext_ids,
-                    rule <- rulesRules (idSpecialisation id),
-                    not (isBuiltinRule rule)
-                       -- We can't print builtin rules in interface files
-                       -- Since they are built in, an importing module
-                       -- will have access to them anyway
+                    rule <- rulesRules (idSpecialisation id)
                 ]
+    needed_rule (id, rule)
+       =  not (isBuiltinRule rule)
+               -- We can't print builtin rules in interface files
+               -- Since they are built in, an importing module
+               -- will have access to them anyway
+
+       && not (any internal_id (varSetElems (ruleLhsFreeIds rule)))
+               -- Don't export a rule whose LHS mentions an Id that
+               -- is completely internal (i.e. not visible to an
+               -- importing module)
+
+    internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids)
 \end{code}
 
 %************************************************************************
@@ -276,7 +289,7 @@ findExternalSet binds orphan_rules
   = foldr find init_needed binds
   where
     orphan_rule_ids :: IdSet
-    orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isLocalId rule 
+    orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule 
                                   | (_, rule) <- orphan_rules]
     init_needed :: IdEnv Bool
     init_needed = mapUFM (\_ -> False) orphan_rule_ids
@@ -500,7 +513,7 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info
     basic_info = vanillaIdInfo 
                        `setCgInfo`            cg_info
                        `setArityInfo`         arity
-                       `setNewStrictnessInfo` newStrictnessInfo idinfo
+                       `setAllStrictnessInfo` newStrictnessInfo idinfo
 
 -- This is where we set names to local/global based on whether they really are 
 -- externally visible (see comment at the top of this module).  If the name
@@ -663,16 +676,19 @@ tidyLetBndr env (id,rhs)
     idinfo   = idInfo id
     new_info = vanillaIdInfo 
                `setArityInfo`          exprArity rhs
-               `setNewStrictnessInfo`  newStrictnessInfo idinfo
+               `setAllStrictnessInfo`  newStrictnessInfo idinfo
                `setNewDemandInfo`      newDemandInfo idinfo
 
     -- Override the env we get back from tidyId with the new IdInfo
     -- so it gets propagated to the usage sites.
     new_var_env = extendVarEnv var_env id final_id
 
+-- Non-top-level variables
 tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
 tidyIdBndr env@(tidy_env, var_env) id
-  =    -- Non-top-level variables
+  = -- do this pattern match strictly, otherwise we end up holding on to
+    -- stuff in the OccName.
+    case tidyOccName tidy_env (getOccName id) of { (tidy_env', occ') -> 
     let 
        -- Give the Id a fresh print-name, *and* rename its type
        -- The SrcLoc isn't important now, 
@@ -680,12 +696,12 @@ tidyIdBndr env@(tidy_env, var_env) id
        -- 
        -- All nested Ids now have the same IdInfo, namely none,
        -- which should save some space.
-       (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
         ty'              = tidyType env (idType id)
        id'               = mkUserLocal occ' (idUnique id) ty' noSrcLoc
        var_env'          = extendVarEnv var_env id id'
     in
      ((tidy_env', var_env'), id')
+   }
 \end{code}
 
 \begin{code}