Second bite at the rules-only idea

[ghc-hetmet.git] / compiler / main / TidyPgm.lhs

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 16df566..976c32e 100644 (file)
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -26,7 +26,7 @@ import Id             ( idType, idInfo, idName, idCoreRules, isGlobalId,
 import IdInfo          {- loads of stuff -}
 import InstEnv         ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
 import NewDemand       ( isBottomingSig, topSig )
-import BasicTypes      ( Arity, isNeverActive )
+import BasicTypes      ( Arity, isNeverActive, isNonRuleLoopBreaker )
 import Name            ( Name, getOccName, nameOccName, mkInternalName,
                          localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
                          isWiredInName, getName
@@ -46,7 +46,9 @@ import Module         ( Module )
 import HscTypes                ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
                          TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, 
                          extendTypeEnvWithIds, lookupTypeEnv,
-                         ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..)
+                         mkDetailsFamInstCache,
+                         ModGuts(..), TyThing(..), ModDetails(..),
+                         Dependencies(..)
                        )
 import Maybes          ( orElse, mapCatMaybes )
 import ErrUtils                ( showPass, dumpIfSet_core )
@@ -135,10 +137,11 @@ mkBootModDetails hsc_env (ModGuts { mg_module = mod,
              ; type_env' = extendTypeEnvWithIds type_env2
                                (map instanceDFunId ispecs')
              }
-       ; return (ModDetails { md_types = type_env',
-                              md_insts = ispecs',
-                              md_rules = [],
-                              md_exports = exports })
+       ; return (ModDetails { md_types     = type_env',
+                              md_insts     = ispecs',
+                              md_fam_insts = mkDetailsFamInstCache type_env',
+                              md_rules     = [],
+                              md_exports   = exports })
        }
   where
 
@@ -290,6 +293,8 @@ tidyProgram hsc_env
                   ModDetails { md_types = tidy_type_env,
                                md_rules = tidy_rules,
                                md_insts = tidy_ispecs,
+                               md_fam_insts = mkDetailsFamInstCache 
+                                                tidy_type_env,
                                md_exports = exports })
        }
 
@@ -446,9 +451,10 @@ addExternal (id,rhs) needed
   = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
                 id show_unfold
   where
-    add_occ id needed = extendVarEnv needed id False
+    add_occ id needed | id `elemVarEnv` needed = needed
+                     | otherwise              = extendVarEnv needed id False
        -- "False" because we don't know we need the Id's unfolding
-       -- We'll override it later when we find the binding site
+       -- Don't override existing bindings; we might have already set it to True
 
     new_needed_ids = worker_ids        `unionVarSet`
                     unfold_ids `unionVarSet`
@@ -456,7 +462,7 @@ addExternal (id,rhs) needed
 
     idinfo        = idInfo id
     dont_inline           = isNeverActive (inlinePragInfo idinfo)
-    loop_breaker   = isLoopBreaker (occInfo idinfo)
+    loop_breaker   = isNonRuleLoopBreaker (occInfo idinfo)
     bottoming_fn   = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
     spec_ids      = specInfoFreeVars (specInfo idinfo)
     worker_info           = workerInfo idinfo