From: simonpj Date: Fri, 3 Nov 2000 17:10:58 +0000 (+0000) Subject: [project @ 2000-11-03 17:10:57 by simonpj] X-Git-Tag: Approximately_9120_patches~3429 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=cd241c73f2b03a48d905e0db50c796eb0de45dec;p=ghc-hetmet.git [project @ 2000-11-03 17:10:57 by simonpj] More renamer... not in a working state I fear --- diff --git a/ghc/compiler/basicTypes/DataCon.lhs b/ghc/compiler/basicTypes/DataCon.lhs index 39f4952..1789370 100644 --- a/ghc/compiler/basicTypes/DataCon.lhs +++ b/ghc/compiler/basicTypes/DataCon.lhs @@ -15,7 +15,7 @@ module DataCon ( dataConSourceArity, dataConRepArity, dataConNumInstArgs, dataConId, dataConWrapId, dataConRepStrictness, isNullaryDataCon, isTupleCon, isUnboxedTupleCon, - isExistentialDataCon, + isExistentialDataCon, classDataCon, splitProductType_maybe, splitProductType, @@ -35,7 +35,7 @@ import Type ( Type, TauType, ClassContext, ) import TyCon ( TyCon, tyConDataCons, tyConDataConsIfAvailable, isDataTyCon, isProductTyCon, isTupleTyCon, isUnboxedTupleTyCon, isRecursiveTyCon ) -import Class ( classTyCon ) +import Class ( Class, classTyCon ) import Name ( Name, NamedThing(..), nameUnique, isLocallyDefined ) import Var ( TyVar, Id ) import FieldLabel ( FieldLabel ) @@ -395,6 +395,12 @@ isExistentialDataCon (MkData {dcExTyVars = tvs}) = not (null tvs) \end{code} +\begin{code} +classDataCon :: Class -> DataCon +classDataCon clas = case tyConDataCons (classTyCon clas) of + (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr +\end{code} + %************************************************************************ %* * \subsection{Splitting products} diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 1d45301..dab3594 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -21,7 +21,7 @@ module RdrName ( -- Environment RdrNameEnv, emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, - extendRdrEnv, rdrEnvToList, elemRdrEnv, + extendRdrEnv, rdrEnvToList, elemRdrEnv, foldRdrEnv, -- Printing; instance Outputable RdrName pprUnqualRdrName @@ -199,6 +199,7 @@ extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] rdrEnvElts :: RdrNameEnv a -> [a] elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool +foldRdrEnv :: (RdrName -> a -> b -> b) -> b -> RdrNameEnv a -> b emptyRdrEnv = emptyFM lookupRdrEnv = lookupFM @@ -207,4 +208,5 @@ rdrEnvElts = eltsFM extendRdrEnv = addToFM rdrEnvToList = fmToList elemRdrEnv = elemFM +foldRdrEnv = foldFM \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 444a4f6..8846a0d 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -51,10 +51,10 @@ import Name -- Env import NameSet ( NameSet ) import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, - lookupModuleEnv, lookupModuleEnvByName + lookupModuleEnv, lookupModuleEnvByName, emptyModuleEnv ) +import InstEnv ( InstEnv, ClsInstEnv, DFunId ) import Rules ( RuleBase ) -import VarSet ( TyVarSet ) import Id ( Id ) import Class ( Class ) import TyCon ( TyCon ) @@ -66,12 +66,10 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) import CoreSyn ( IdCoreRule ) -import Type ( Type ) import FiniteMap ( FiniteMap ) import Bag ( Bag ) import Maybes ( seqMaybe ) -import UniqFM ( UniqFM, emptyUFM ) import Outputable import SrcLoc ( SrcLoc, isGoodSrcLoc ) import Util ( thenCmp ) @@ -193,7 +191,7 @@ type PackageIfaceTable = IfaceTable type HomeSymbolTable = SymbolTable -- Domain = modules in the home package emptyIfaceTable :: IfaceTable -emptyIfaceTable = emptyUFM +emptyIfaceTable = emptyModuleEnv \end{code} Simple lookups in the symbol table. @@ -308,11 +306,6 @@ lookupDeprec (DeprecAll txt) name = Just txt lookupDeprec (DeprecSome env) name = case lookupNameEnv env name of Just (_, txt) -> Just txt Nothing -> Nothing - -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class - -type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class -type DFunId = Id \end{code} @@ -483,7 +476,7 @@ type DeclsMap = NameEnv (AvailInfo, Bool, (Module, RdrNameTyClDecl)) type IfaceInsts = Bag GatedDecl type IfaceRules = Bag GatedDecl -type GatedDecl = (NameSet, (Module, RdrNameHsDecl)) +type GatedDecl = ([Name], (Module, RdrNameHsDecl)) \end{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index a54934d..c1e1dad 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -30,7 +30,7 @@ import RnHiFiles ( readIface, removeContext, import RnEnv ( availName, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupGlobalRn, newGlobalName + lookupOrigNames, lookupSrcName, newGlobalName ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, @@ -41,7 +41,7 @@ import Name ( Name, NamedThing(..), getSrcLoc, nameOccName, nameModule, ) import Name ( mkNameEnv, nameEnvElts, extendNameEnv ) -import RdrName ( elemRdrEnv ) +import RdrName ( elemRdrEnv, foldRdrEnv, isQual ) import OccName ( occNameFlavour ) import NameSet import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) @@ -149,6 +149,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) -- when compiling the prelude, locally-defined (), Bool, etc -- override the implicit ones. in + traceRn (text "Source FVs:" <+> fsep (map ppr (nameSetToList slurp_fvs))) `thenRn_` slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND @@ -291,39 +292,31 @@ isOrphanDecl _ _ = False \begin{code} fixitiesFromLocalDecls :: GlobalRdrEnv -> [RdrNameHsDecl] -> RnMG LocalFixityEnv fixitiesFromLocalDecls gbl_env decls - = doptRn Opt_WarnUnusedBinds `thenRn` \ warn_unused -> - foldlRn (getFixities warn_unused) emptyNameEnv decls `thenRn` \ env -> - traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) - `thenRn_` + = foldlRn getFixities emptyNameEnv decls `thenRn` \ env -> + traceRn (text "fixity env" <+> vcat (map ppr (nameEnvElts env))) `thenRn_` returnRn env where - getFixities :: Bool -> LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv - getFixities warn_uu acc (FixD fix) - = fix_decl warn_uu acc fix + getFixities :: LocalFixityEnv -> RdrNameHsDecl -> RnMG LocalFixityEnv + getFixities acc (FixD fix) + = fix_decl acc fix - getFixities warn_uu acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ )) - = foldlRn (fix_decl warn_uu) acc [sig | FixSig sig <- sigs] + getFixities acc (TyClD (ClassDecl _ _ _ _ sigs _ _ _ )) + = foldlRn fix_decl acc [sig | FixSig sig <- sigs] -- Get fixities from class decl sigs too. - getFixities warn_uu acc other_decl + getFixities acc other_decl = returnRn acc - fix_decl warn_uu acc sig@(FixitySig rdr_name fixity loc) + fix_decl acc sig@(FixitySig rdr_name fixity loc) = -- Check for fixity decl for something not declared pushSrcLocRn loc $ - lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name -> - case maybe_name of { - Nothing -> checkRn (not warn_uu) (unusedFixityDecl rdr_name fixity) `thenRn_` - returnRn acc ; - - Just name -> + lookupSrcName gbl_env rdr_name `thenRn` \ name -> -- Check for duplicate fixity decl - case lookupNameEnv acc name of { - Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') - `thenRn_` returnRn acc ; + case lookupNameEnv acc name of + Just (FixitySig _ _ loc') -> addErrRn (dupFixityDecl rdr_name loc loc') `thenRn_` + returnRn acc ; - Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc)) - }} + Nothing -> returnRn (extendNameEnv acc name (FixitySig name fixity loc)) \end{code} @@ -352,11 +345,9 @@ rnDeprecs gbl_env Nothing decls returnRn (DeprecSome (mkNameEnv (catMaybes pairs))) where rn_deprec (Deprecation rdr_name txt loc) - = pushSrcLocRn loc $ - lookupGlobalRn gbl_env rdr_name `thenRn` \ maybe_name -> - case maybe_name of - Just n -> returnRn (Just (n,(n,txt))) - Nothing -> returnRn Nothing + = pushSrcLocRn loc $ + lookupSrcName gbl_env rdr_name `thenRn` \ name -> + returnRn (Just (name, (name,txt))) \end{code} @@ -543,6 +534,7 @@ reportUnusedNames my_mod_iface imports avail_env warnUnusedImports bad_imp_names `thenRn_` printMinimalImports this_mod minimal_imports `thenRn_` warnDeprecations this_mod my_deprecs really_used_names `thenRn_` + traceRn (text "Used" <+> fsep (map ppr (nameSetToList used_names))) `thenRn_` returnRn () where @@ -569,10 +561,16 @@ reportUnusedNames my_mod_iface imports avail_env other -> Nothing] ] - defined_names, defined_and_used, defined_but_not_used :: [(Name,Provenance)] - defined_names = concat (rdrEnvElts gbl_env) + -- Collect the defined names from the in-scope environment + -- Look for the qualified ones only, else get duplicates + defined_names :: [(Name,Provenance)] + defined_names = foldRdrEnv add [] gbl_env + add rdr_name ns acc | isQual rdr_name = ns ++ acc + | otherwise = acc + + defined_and_used, defined_but_not_used :: [(Name,Provenance)] (defined_and_used, defined_but_not_used) = partition used defined_names - used (name,_) = not (name `elemNameSet` really_used_names) + used (name,_) = name `elemNameSet` really_used_names -- Filter out the ones only defined implicitly bad_locals :: [Name] @@ -801,9 +799,6 @@ warnDeprec (name, txt) text "is deprecated:", nest 4 (ppr txt) ] -unusedFixityDecl rdr_name fixity - = hsep [ptext SLIT("Unused fixity declaration for"), quotes (ppr rdr_name)] - dupFixityDecl rdr_name loc1 loc2 = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), ptext SLIT("at ") <+> ppr loc1, diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index a3c31d6..b991dc8 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -180,7 +180,8 @@ lookupTopBndrRn rdr_name -- if there are many with the same occ name -- There must *be* a binding getModuleRn `thenRn` \ mod -> - lookupSrcGlobalOcc (qualifyRdrName (moduleName mod) rdr_name) + getGlobalNameEnv `thenRn` \ global_env -> + lookupSrcName global_env (qualifyRdrName (moduleName mod) rdr_name) -- lookupSigOccRn is used for type signatures and pragmas -- Is this valid? @@ -209,19 +210,21 @@ lookupOccRn rdr_name -- class op names in class and instance decls lookupGlobalOccRn rdr_name + = getModeRn `thenRn` \ mode -> + case mode of + SourceMode -> getGlobalNameEnv `thenRn` \ global_env -> + lookupSrcName global_env rdr_name + + InterfaceMode -> lookupIfaceName rdr_name + +lookupSrcName :: GlobalRdrEnv -> RdrName -> RnM d Name +-- NB: passed GlobalEnv explicitly, not necessarily in RnMS monad +lookupSrcName global_env rdr_name | isOrig rdr_name -- Can occur in source code too = lookupOrigName rdr_name | otherwise - = getModeRn `thenRn` \ mode -> - case mode of - SourceMode -> lookupSrcGlobalOcc rdr_name - InterfaceMode -> lookupIfaceUnqual rdr_name - -lookupSrcGlobalOcc rdr_name - -- Lookup a source-code rdr-name; may be qualified or not - = getGlobalNameEnv `thenRn` \ global_env -> - case lookupRdrEnv global_env rdr_name of + = case lookupRdrEnv global_env rdr_name of Just [(name,_)] -> returnRn name Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_` returnRn name @@ -246,15 +249,6 @@ lookupIfaceName :: RdrName -> RnM d Name lookupIfaceName rdr_name | isUnqual rdr_name = lookupIfaceUnqual rdr_name | otherwise = lookupOrigName rdr_name - -lookupGlobalRn :: GlobalRdrEnv -> RdrName -> RnM d (Maybe Name) - -- Checks that there is exactly one -lookupGlobalRn global_env rdr_name - = case lookupRdrEnv global_env rdr_name of - Just [(name,_)] -> returnRn (Just name) - Just stuff@((name,_):_) -> addNameClashErrRn rdr_name stuff `thenRn_` - returnRn (Just name) - Nothing -> returnRn Nothing \end{code} @lookupOrigName@ takes an RdrName representing an {\em original} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 4af718e..7a2cd23 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -342,7 +342,7 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc) in setModuleRn mod $ mapRn lookupIfaceName free_names `thenRn` \ gate_names -> - returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts) + returnRn ((gate_names, (mod, InstD decl)) `consBag` insts) -- In interface files, the instance decls now look like @@ -376,7 +376,7 @@ loadRule :: Module -> RdrNameRuleDecl -> RnM d GatedDecl -- needed. We can refine this later. loadRule mod decl@(IfaceRule _ _ var _ _ src_loc) = lookupIfaceName var `thenRn` \ var_name -> - returnRn (unitNameSet var_name, (mod, RuleD decl)) + returnRn ([var_name], (mod, RuleD decl)) ----------------------------------------------------- diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index b1a9d0f..c8691df 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -33,6 +33,7 @@ import RnSource ( rnTyClDecl, rnDecl ) import RnEnv import RnMonad import Id ( idType ) +import DataCon ( classDataCon, dataConId ) import Type ( namesOfType ) import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, @@ -78,80 +79,6 @@ getInterfaceExports mod_name from %********************************************************* %* * -\subsection{Instance declarations are handled specially} -%* * -%********************************************************* - -\begin{code} -getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] -getImportedInstDecls gates - = -- First, load any orphan-instance modules that aren't aready loaded - -- Orphan-instance modules are recorded in the module dependecnies - getIfacesRn `thenRn` \ ifaces -> - let - orphan_mods = - [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)] - in - loadOrphanModules orphan_mods `thenRn_` - - -- Now we're ready to grab the instance declarations - -- Find the un-gated ones and return them, - -- removing them from the bag kept in Ifaces - getIfacesRn `thenRn` \ ifaces -> - let - (decls, new_insts) = selectGated gates (iInsts ifaces) - in - setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` - - traceRn (sep [text "getImportedInstDecls:", - nest 4 (fsep (map ppr gate_list)), - text "Slurped" <+> int (length decls) <+> text "instance declarations", - nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_` - returnRn decls - where - gate_list = nameSetToList gates - -ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _)) - = case inst_ty of - HsForAllTy _ _ tau -> ppr tau - other -> ppr inst_ty - -getImportedRules :: RnMG [(Module,RdrNameHsDecl)] -getImportedRules - | opt_IgnoreIfacePragmas = returnRn [] - | otherwise - = getIfacesRn `thenRn` \ ifaces -> - let - gates = iSlurp ifaces -- Anything at all that's been slurped - rules = iRules ifaces - (decls, new_rules) = selectGated gates rules - in - if null decls then - returnRn [] - else - setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` - traceRn (sep [text "getImportedRules:", - text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` - returnRn decls - -selectGated gates decl_bag - -- Select only those decls whose gates are *all* in 'gates' -#ifdef DEBUG - | opt_NoPruneDecls -- Just to try the effect of not gating at all - = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all - - | otherwise -#endif - = foldrBag select ([], emptyBag) decl_bag - where - select (reqd, decl) (yes, no) - | isEmptyNameSet (reqd `minusNameSet` gates) = (decl:yes, no) - | otherwise = (yes, (reqd,decl) `consBag` no) -\end{code} - - -%********************************************************* -%* * \subsection{Keeping track of what we've slurped, and version numbers} %* * %********************************************************* @@ -379,9 +306,9 @@ slurpSourceRefs source_binders source_fvs go_inner (decls, fvs, gates) wanted_name = importDecl wanted_name `thenRn` \ import_result -> case import_result of - AlreadySlurped -> returnRn (decls, fvs, gates) - WiredIn -> returnRn (decls, fvs, gates `plusFV` getWiredInGates wanted_name) - Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor + AlreadySlurped -> returnRn (decls, fvs, gates) + InTypeEnv ty_thing -> returnRn (decls, fvs, gates `plusFV` getWiredInGates ty_thing) + Deferred -> returnRn (decls, fvs, gates `addOneFV` wanted_name) -- It's a type constructor HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> returnRn (TyClD new_decl : decls, @@ -530,33 +457,73 @@ stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2)) %* * %********************************************************* +The gating story +~~~~~~~~~~~~~~~~~ +We want to avoid sucking in too many instance declarations. +An instance decl is only useful if the types and classes mentioned in +its 'head' are all available in the program being compiled. E.g. + + instance (..) => C (T1 a) (T2 b) where ... + +is only useful if C, T1 and T2 are all available. So we keep +instance decls that have been parsed from .hi files, but not yet +slurped in, in a pool called the 'gated instance pool'. +Each has its set of 'gates': {C, T1, T2} in the above example. + +THE GATING INVARIANT + + *All* the instances whose gates are entirely in the stuff that's + already been through the type checker (i.e. are already in the + Persistent Type Environment or Home Symbol Table) have already been + slurped in, and are no longer in the gated instance pool. + +Hence, when we read a new module, we see what new gates we have, +and let in any instance decls whose gates are + either in the new gates, + or in the HST/PTE + +An earlier optimisation: now infeasible +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we import a declaration like \begin{verbatim} data T = T1 Wibble | T2 Wobble \end{verbatim} -we don't want to treat @Wibble@ and @Wobble@ as gates -{\em unless} @T1@, @T2@ respectively are mentioned by the user program. -If only @T@ is mentioned -we want only @T@ to be a gate; -that way we don't suck in useless instance -decls for (say) @Eq Wibble@, when they can't possibly be useful. +we don't want to treat @Wibble@ and @Wobble@ as gates {\em unless} +@T1@, @T2@ respectively are mentioned by the user program. If only +@T@ is mentioned we want only @T@ to be a gate; that way we don't suck +in useless instance decls for (say) @Eq Wibble@, when they can't +possibly be useful. + +BUT, I can't see how to do this and still maintain the GATING INVARIANT. +So I've simply ditched the optimisation to get things working. + + + @getGates@ takes a newly imported (and renamed) decl, and the free vars of the source program, and extracts from the decl the gate names. \begin{code} -getGates source_fvs (IfaceSig _ ty _ _) +getGates :: FreeVars -- Things mentioned in the source program + -> RenamedHsDecl + -> FreeVars + +get_gates source_fvs decl = get_gates (\n -> True) decl + -- We'd use (\n -> n `elemNameSet` source_fvs) + -- if we were using the 'earlier optimisation above + +get_gates is_used (IfaceSig _ ty _ _) = extractHsTyNames ty -getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ ) +get_gates is_used (ClassDecl ctxt cls tvs _ sigs _ _ _ ) = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) (hsTyVarNames tvs) `addOneToNameSet` cls) `plusFV` maybe_double where get (ClassOpSig n _ ty _) - | n `elemNameSet` source_fvs = extractHsTyNames ty - | otherwise = emptyFVs + | is_used n = extractHsTyNames ty + | otherwise = emptyFVs -- If we load any numeric class that doesn't have -- Int as an instance, add Double to the gates. @@ -568,18 +535,17 @@ getGates source_fvs (ClassDecl ctxt cls tvs _ sigs _ _ _ ) | otherwise = emptyFVs -getGates source_fvs (TySynonym tycon tvs ty _) - = delListFromNameSet (extractHsTyNames ty) - (hsTyVarNames tvs) +get_gates is_used (TySynonym tycon tvs ty _) + = delListFromNameSet (extractHsTyNames ty) (hsTyVarNames tvs) -- A type synonym type constructor isn't a "gate" for instance decls -getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _) +get_gates is_used (TyData _ ctxt tycon tvs cons _ _ _ _ _) = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) (hsTyVarNames tvs) `addOneToNameSet` tycon where get (ConDecl n _ tvs ctxt details _) - | n `elemNameSet` source_fvs + | is_used n -- If the constructor is method, get fvs from all its fields = delListFromNameSet (get_details details `plusFV` extractHsCtxtTyNames ctxt) @@ -597,8 +563,8 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _) get_details (InfixCon t1 t2) = get_bang t1 `plusFV` get_bang t2 get_details (RecCon fields) = plusFVs [get_bang t | (_, t) <- fields] - get_field (fs,t) | any (`elemNameSet` source_fvs) fs = get_bang t - | otherwise = emptyFVs + get_field (fs,t) | any is_used fs = get_bang t + | otherwise = emptyFVs get_bang bty = extractHsTyNames (getBangType bty) \end{code} @@ -607,18 +573,23 @@ getGates source_fvs (TyData _ ctxt tycon tvs cons _ _ _ _ _) rather than a declaration. \begin{code} -getWiredInGates :: Name -> FreeVars -getWiredInGates name -- No classes are wired in - = case lookupNameEnv wiredInThingEnv name of - Just (AnId the_id) -> getWiredInGates_s (namesOfType (idType the_id)) - - Just (ATyCon tc) - | isSynTyCon tc - -> getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) - where - (tyvars,ty) = getSynTyConDefn tc - - other -> unitFV name +getWiredInGates :: TyThing -> FreeVars +-- The TyThing is one that we already have in our type environment, either +-- a) because the TyCon or Id is wired in, or +-- b) from a previous compile +-- Either way, we might have instance decls in the (persistend) collection +-- of parsed-but-not-slurped instance decls that should be slurped in. +-- This might be the first module that mentions both the type and the class +-- for that instance decl, even though both the type and the class were +-- mentioned in other modules, and hence are in the type environment + +getWiredInGates (AnId the_id) = getWiredInGates_s (namesOfType (idType the_id)) +getWiredInGates (AClass cl) = namesOfType (idType (dataConId (classDataCon cl))) -- Cunning +getWiredInGates (ATyCon tc) + | isSynTyCon tc = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars)) + | otherwise = unitFV (getName tc) + where + (tyvars,ty) = getSynTyConDefn tc getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) \end{code} @@ -628,6 +599,77 @@ getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty getInstDeclGates other = emptyFVs \end{code} +\begin{code} +getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] +getImportedInstDecls gates + = -- First, load any orphan-instance modules that aren't aready loaded + -- Orphan-instance modules are recorded in the module dependecnies + getIfacesRn `thenRn` \ ifaces -> + let + orphan_mods = + [mod | (mod, (True, _)) <- fmToList (iImpModInfo ifaces)] + in + loadOrphanModules orphan_mods `thenRn_` + + -- Now we're ready to grab the instance declarations + -- Find the un-gated ones and return them, + -- removing them from the bag kept in Ifaces + getIfacesRn `thenRn` \ ifaces -> + getTypeEnvRn `thenRn` \ lookup -> + let + (decls, new_insts) = selectGated gates lookup (iInsts ifaces) + in + setIfacesRn (ifaces { iInsts = new_insts }) `thenRn_` + + traceRn (sep [text "getImportedInstDecls:", + nest 4 (fsep (map ppr gate_list)), + text "Slurped" <+> int (length decls) <+> text "instance declarations", + nest 4 (vcat (map ppr_brief_inst_decl decls))]) `thenRn_` + returnRn decls + where + gate_list = nameSetToList gates + +ppr_brief_inst_decl (mod, InstD (InstDecl inst_ty _ _ _ _)) + = case inst_ty of + HsForAllTy _ _ tau -> ppr tau + other -> ppr inst_ty + +getImportedRules :: RnMG [(Module,RdrNameHsDecl)] +getImportedRules + | opt_IgnoreIfacePragmas = returnRn [] + | otherwise + = getIfacesRn `thenRn` \ ifaces -> + getTypeEnvRn `thenRn` \ lookup -> + let + gates = iSlurp ifaces -- Anything at all that's been slurped + rules = iRules ifaces + (decls, new_rules) = selectGated gates lookup rules + in + if null decls then + returnRn [] + else + setIfacesRn (ifaces { iRules = new_rules }) `thenRn_` + traceRn (sep [text "getImportedRules:", + text "Slurped" <+> int (length decls) <+> text "rules"]) `thenRn_` + returnRn decls + +selectGated gates lookup decl_bag + -- Select only those decls whose gates are *all* in 'gates' + -- or are in the range of lookup +#ifdef DEBUG + | opt_NoPruneDecls -- Just to try the effect of not gating at all + = (foldrBag (\ (_,d) ds -> d:ds) [] decl_bag, emptyBag) -- Grab them all + + | otherwise +#endif + = foldrBag select ([], emptyBag) decl_bag + where + available n = n `elemNameSet` gates || maybeToBool (lookup n) + select (reqd, decl) (yes, no) + | all available reqd = (decl:yes, no) + | otherwise = (yes, (reqd,decl) `consBag` no) +\end{code} + %********************************************************* %* * @@ -640,42 +682,57 @@ importDecl :: Name -> RnMG ImportDeclResult data ImportDeclResult = AlreadySlurped - | WiredIn + | InTypeEnv TyThing | Deferred | HereItIs (Module, RdrNameTyClDecl) importDecl name - = -- Check if it was loaded before beginning this module + = -- STEP 1: Check if it was loaded before beginning this module if isLocalName name then + traceRn (text "Already (local)" <+> ppr name) `thenRn_` returnRn AlreadySlurped else - checkAlreadyAvailable name `thenRn` \ done -> - if done then - returnRn AlreadySlurped - else - -- Check if we slurped it in while compiling this module + -- STEP 2: Check if it's already in the type environment + getTypeEnvRn `thenRn` \ lookup -> + case lookup name of { + Just ty_thing | name `elemNameEnv` wiredInThingEnv + -> -- When we find a wired-in name we must load its home + -- module so that we find any instance decls lurking therein + loadHomeInterface wi_doc name `thenRn_` + returnRn (InTypeEnv (getWiredInGates ty_thing)) + + | otherwise + -> returnRn (InTypeEnv ty_thing) ; + + Nothing -> + + -- STEP 3: Check if we've slurped it in while compiling this module getIfacesRn `thenRn` \ ifaces -> if name `elemNameSet` iSlurp ifaces then returnRn AlreadySlurped - else + else - -- When we find a wired-in name we must load its home - -- module so that we find any instance decls lurking therein - if name `elemNameEnv` wiredInThingEnv then - loadHomeInterface doc name `thenRn_` - returnRn WiredIn + -- STEP 4: OK, we have to slurp it in from an interface file + -- First load the interface file + traceRn nd_doc `thenRn_` + loadHomeInterface nd_doc name `thenRn_` + getIfacesRn `thenRn` \ ifaces -> + + -- STEP 5: Get the declaration out + case lookupNameEnv (iDecls ifaces) name of + Just (avail,_,decl) + -> setIfacesRn (recordSlurp ifaces avail) `thenRn_` + returnRn (HereItIs decl) - else getNonWiredInDecl name + Nothing + -> addErrRn (getDeclErr name) `thenRn_` + returnRn AlreadySlurped + } where - doc = ptext SLIT("need home module for wired in thing") <+> ppr name + wi_doc = ptext SLIT("need home module for wired in thing") <+> ppr name + nd_doc = ptext SLIT("need decl for") <+> ppr name -getNonWiredInDecl :: Name -> RnMG ImportDeclResult -getNonWiredInDecl needed_name - = traceRn doc_str `thenRn_` - loadHomeInterface doc_str needed_name `thenRn_` - getIfacesRn `thenRn` \ ifaces -> - case lookupNameEnv (iDecls ifaces) needed_name of {- OMIT DEFERRED STUFF FOR NOW, TILL GHCI WORKS Just (version, avail, is_tycon_name, decl@(_, TyClD (TyData DataType _ _ _ _ ncons _ _ _ _))) @@ -716,16 +773,6 @@ getNonWiredInDecl needed_name tycon_name = availName avail -} - Just (avail,_,decl) - -> setIfacesRn (recordSlurp ifaces avail) `thenRn_` - returnRn (HereItIs decl) - - Nothing - -> addErrRn (getDeclErr needed_name) `thenRn_` - returnRn AlreadySlurped - where - doc_str = ptext SLIT("need decl for") <+> ppr needed_name - {- OMIT FOR NOW getDeferredDecls :: RnMG [(Module, RdrNameHsDecl)] getDeferredDecls diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index a1b9d77..0d562d3 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -40,7 +40,7 @@ import HscTypes ( AvailEnv, lookupType, WhetherHasOrphans, ImportVersion, PersistentRenamerState(..), IsBootInterface, Avails, DeclsMap, IfaceInsts, IfaceRules, - HomeSymbolTable, PackageTypeEnv, + HomeSymbolTable, TyThing, PersistentCompilerState(..), GlobalRdrEnv, HomeIfaceTable, PackageIfaceTable, RdrAvailInfo ) @@ -67,7 +67,6 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable import PrelNames ( mkUnboundName ) -import Maybes ( maybeToBool ) import ErrUtils ( printErrorsAndWarnings ) infixr 9 `thenRn`, `thenRn_` @@ -127,11 +126,13 @@ data RnDown rn_dflags :: DynFlags, rn_hit :: HomeIfaceTable, - rn_done :: Name -> Bool, -- Tells what things (both in the - -- home package and other packages) - -- were already available (i.e. in - -- the relevant SymbolTable) before - -- compiling this module + rn_done :: Name -> Maybe TyThing, -- Tells what things (both in the + -- home package and other packages) + -- were already available (i.e. in + -- the relevant SymbolTable) before + -- compiling this module + -- The Name passed to rn_done is guaranteed to be a Global, + -- so it has a Module, so it can be looked up rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), @@ -330,7 +331,7 @@ initRn dflags hit hst pcs mod do_rn rn_dflags = dflags, rn_hit = hit, - rn_done = is_done hst pte, + rn_done = lookupType hst pte, rn_ns = names_var, rn_errs = errs_var, @@ -358,11 +359,6 @@ initRn dflags hit hst pcs mod do_rn return (new_pcs, not (isEmptyBag errs), res) -is_done :: HomeSymbolTable -> PackageTypeEnv -> Name -> Bool --- Returns True iff the name is in either symbol table --- The name is a Global, so it has a Module -is_done hst pte n = maybeToBool (lookupType hst pte n) - initRnMS rn_env fixity_env mode thing_inside rn_down g_down -- The fixity_env appears in both the rn_fixenv field -- and in the HIT. See comments with RnHiFiles.lookupFixityRn @@ -589,9 +585,8 @@ getSrcLocRn down l_down getHomeIfaceTableRn :: RnM d HomeIfaceTable getHomeIfaceTableRn down l_down = return (rn_hit down) -checkAlreadyAvailable :: Name -> RnM d Bool - -- Name is a Global name -checkAlreadyAvailable name down l_down = return (rn_done down name) +getTypeEnvRn :: RnM d (Name -> Maybe TyThing) +getTypeEnvRn down l_down = return (rn_done down) \end{code} %================ diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index f62fc86..a66c451 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -542,46 +542,37 @@ exportsFromAvail this_mod (Just export_items) returnRn (mod:mods, occs', avails') exports_from_item warn_dups acc@(mods, occs, avails) ie - | not (maybeToBool maybe_in_scope) - = failWithRn acc (unknownNameErr (ieName ie)) + = lookupSrcName global_name_env (ieName ie) `thenRn` \ name -> - | not (null dup_names) - = addNameClashErrRn rdr_name ((name,prov):dup_names) `thenRn_` - returnRn acc - -#ifdef DEBUG - -- I can't see why this should ever happen; if the thing is in scope - -- at all it ought to have some availability - | not (maybeToBool maybe_avail) - = pprTrace "exportsFromAvail: curious Nothing:" (ppr name) - returnRn acc -#endif + -- See what's available in the current environment + case lookupUFM entity_avail_env name of { + Nothing -> -- I can't see why this should ever happen; if the thing + -- is in scope at all it ought to have some availability + pprTrace "exportsFromAvail: curious Nothing:" (ppr name) + returnRn acc ; - | not enough_avail - = failWithRn acc (exportItemErr ie) + Just avail -> - | otherwise -- Phew! It's OK! Now to check the occurrence stuff! + -- Filter out the bits we want + case filterAvail ie avail of { + Nothing -> -- Not enough availability + failWithRn acc (exportItemErr ie) ; + Just export_avail -> - = warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` + -- Phew! It's OK! Now to check the occurrence stuff! + warnCheckRn (ok_item ie avail) (dodgyExportWarn ie) `thenRn_` check_occs ie occs export_avail `thenRn` \ occs' -> returnRn (mods, occs', addAvail avails export_avail) + }} + + - where - rdr_name = ieName ie - maybe_in_scope = lookupFM global_name_env rdr_name - Just ((name,prov):dup_names) = maybe_in_scope - maybe_avail = lookupUFM entity_avail_env name - Just avail = maybe_avail - maybe_export_avail = filterAvail ie avail - enough_avail = maybeToBool maybe_export_avail - Just export_avail = maybe_export_avail - - ok_item (IEThingAll _) (AvailTC _ [n]) = False - -- This occurs when you import T(..), but - -- only export T abstractly. The single [n] - -- in the AvailTC is the type or class itself - ok_item _ _ = True +ok_item (IEThingAll _) (AvailTC _ [n]) = False + -- This occurs when you import T(..), but + -- only export T abstractly. The single [n] + -- in the AvailTC is the type or class itself +ok_item _ _ = True check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnMG ExportOccMap check_occs ie occs avail diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index aa0a869..8289392 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -298,7 +298,7 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) case maybe_ty2 of Just ty2' -> uUnboundVar swapped tv1 maybe_ty1 ty2' ty2' - Nothing | tv1_dominates_tv2 + Nothing | update_tv2 -> WARN( not (k1 `hasMoreBoxityInfo` k2), (ppr tv1 <+> ppr k1) $$ (ppr tv2 <+> ppr k2) ) tcPutTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` @@ -312,10 +312,11 @@ uUnboundVar swapped tv1 maybe_ty1 ps_ty2 ty2@(TyVarTy tv2) where k1 = tyVarKind tv1 k2 = tyVarKind tv2 - tv1_dominates_tv2 = isSigTyVar tv1 + update_tv2 = (k2 == openTypeKind) || (k1 /= openTypeKind && nicer_to_update_tv2) + -- Try to get rid of open type variables as soon as poss + + nicer_to_update_tv2 = isSigTyVar tv1 -- Don't unify a signature type variable if poss - || k2 == openTypeKind - -- Try to get rid of open type variables as soon as poss || isSystemName (varName tv2) -- Try to update sys-y type variables in preference to sig-y ones diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 90ae4c1..7ca6cf6 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,18 +7,18 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - -- Instance environment - InstEnv, emptyInstEnv, extendInstEnv, + DFunId, ClsInstEnv, InstEnv, + + emptyInstEnv, extendInstEnv, lookupInstEnv, InstLookupResult(..), - classInstEnv, classDataCon, simpleDFunClassTyCon + classInstEnv, simpleDFunClassTyCon ) where #include "HsVersions.h" -import HscTypes ( InstEnv, ClsInstEnv, DFunId ) import Class ( Class ) import Var ( Id ) -import VarSet ( unionVarSet, mkVarSet ) +import VarSet ( TyVarSet, unionVarSet, mkVarSet ) import VarEnv ( TyVarSubstEnv ) import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) import Name ( getSrcLoc ) @@ -26,23 +26,30 @@ import Type ( Type, splitTyConApp_maybe, splitSigmaTy, splitDFunTy, tyVarsOfTypes ) import PprType ( ) -import Class ( classTyCon ) import DataCon ( DataCon ) -import TyCon ( TyCon, tyConDataCons ) +import TyCon ( TyCon ) import Outputable import Unify ( matchTys, unifyTyListsX ) -import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM ) +import UniqFM ( UniqFM, lookupWithDefaultUFM, addToUFM, emptyUFM ) import Id ( idType ) import ErrUtils ( Message ) import CmdLineOpts \end{code} - -A tiny function which doesn't belong anywhere else. -It makes a nasty mutual-recursion knot if you put it in Class. +%************************************************************************ +%* * +\subsection{The key types} +%* * +%************************************************************************ \begin{code} +type DFunId = Id + +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class + +type ClsInstEnv = [(TyVarSet, [Type], DFunId)] -- The instances for a particular class + simpleDFunClassTyCon :: DFunId -> (Class, TyCon) simpleDFunClassTyCon dfun = (clas, tycon) @@ -50,10 +57,6 @@ simpleDFunClassTyCon dfun (_,_,clas,[ty]) = splitDFunTy (idType dfun) tycon = case splitTyConApp_maybe ty of Just (tycon,_) -> tycon - -classDataCon :: Class -> DataCon -classDataCon clas = case tyConDataCons (classTyCon clas) of - (dict_constr:no_more) -> ASSERT( null no_more ) dict_constr \end{code} %************************************************************************