X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fmain%2FTidyPgm.lhs;h=976c32e1669ddccba547c6846db0fb9b988aca65;hb=a35f75aa20bf0a329be0b782986c3e12155b4d49;hp=c0d19df90a3cc077375d4ea370ee50084f30a69c;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc;p=ghc-hetmet.git

diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index c0d19df..976c32e 100644
--- 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
@@ -39,13 +39,16 @@ import Type		( tidyTopType )
 import TcType		( isFFITy )
 import DataCon		( dataConName, dataConFieldLabels, dataConWrapId_maybe )
 import TyCon		( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, 
-			  newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon )
+			  newTyConRep, tyConSelIds, isAlgTyCon,
+			  isEnumerationTyCon, isOpenTyCon )
 import Class		( classSelIds )
 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 )
@@ -134,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
 
@@ -289,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 })
 	}
 
@@ -351,6 +357,8 @@ mustExposeTyCon exports tc
   | isEnumerationTyCon tc	-- For an enumeration, exposing the constructors
   = True			-- won't lead to the need for further exposure
 				-- (This includes data types with no constructors.)
+  | isOpenTyCon tc		-- open type family
+  = True
   | otherwise			-- Newtype, datatype
   = any exported_con (tyConDataCons tc)
 	-- Expose rep if any datacon or field is exported
@@ -443,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`
@@ -453,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
@@ -806,6 +815,7 @@ cafRefs p (Lam x e) 	       = cafRefs p e
 cafRefs p (Let b e) 	       = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
 cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
 cafRefs p (Note n e) 	       = cafRefs p e
+cafRefs p (Cast e co)          = cafRefs p e
 cafRefs p (Type t) 	       = fastBool False
 
 cafRefss p [] 	  = fastBool False