From: simonpj Date: Wed, 16 May 2001 12:44:20 +0000 (+0000) Subject: [project @ 2001-05-16 12:44:20 by simonpj] X-Git-Tag: Approximately_9120_patches~1945 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=a4a632f53f22c4cff2c7cc6171c94da5dc2a2530;p=ghc-hetmet.git [project @ 2001-05-16 12:44:20 by simonpj] Import Double when necessary to make defaulting work --- diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 1db8e37..d402a4c 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -12,6 +12,7 @@ import {-# SOURCE #-} RnHiFiles import HsSyn import RdrHsSyn ( RdrNameIE ) +import RnHsSyn ( RenamedTyClDecl ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, mkRdrUnqual, mkRdrQual, lookupRdrEnv, foldRdrEnv ) @@ -411,21 +412,6 @@ ubiquitousNames \end{code} \begin{code} -implicitGates :: Name -> FreeVars --- If we load class Num, add Integer to the gates --- This takes account of the fact that Integer might be needed for --- defaulting, but we don't want to load Integer (and all its baggage) --- if there's no numeric stuff needed. --- Similarly for class Fractional and Double --- --- NB: If we load (say) Floating, we'll end up loading Fractional too, --- since Fractional is a superclass of Floating -implicitGates cls | cls `hasKey` numClassKey = unitFV integerTyConName - | cls `hasKey` fractionalClassKey = unitFV doubleTyConName - | otherwise = emptyFVs -\end{code} - -\begin{code} rnSyntaxNames :: GlobalRdrEnv -> FreeVars -> RnMG (FreeVars, SyntaxMap) -- Look up the re-bindable syntactic sugar names -- Any errors arising from these lookups may surprise the diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 93f4732..7cab59c 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -53,7 +53,8 @@ import Module ( Module, ModuleEnv, extendModuleEnv_C, foldModuleEnv, lookupModuleEnv, elemModuleSet, extendModuleSet ) -import PrelInfo ( wiredInThingEnv ) +import PrelInfo ( wiredInThingEnv, hasKey, fractionalClassKey, numClassKey, + integerTyConName, doubleTyConName ) import Maybes ( maybeToBool ) import FiniteMap import Outputable @@ -271,6 +272,15 @@ slurpSourceRefs source_fvs -- and the instance decls -- The outer loop is needed because consider + -- instance Foo a => Baz (Maybe a) where ... + -- It may be that Baz and Maybe are used in the source module, + -- but not Foo; so we need to chase Foo too. + -- + -- We also need to follow superclass refs. In particular, 'chasing Foo' must + -- include actually getting in Foo's class decl + -- class Wib a => Foo a where .. + -- so that its superclasses are discovered. The point is that Wib is a gate too. + -- We do this for tycons too, so that we look through type synonyms. go_outer decls fvs all_gates [] = returnRn (decls, fvs) @@ -284,6 +294,7 @@ slurpSourceRefs source_fvs (nameSetToList (gates2 `minusNameSet` all_gates)) -- Knock out the all_gates because even if we don't slurp any new -- decls we can get some apparently-new gates from wired-in names + -- and we get an infinite loop go_inner (decls, fvs, gates) wanted_name = importDecl wanted_name `thenRn` \ import_result -> @@ -481,11 +492,11 @@ getGates source_fvs decl get_gates is_used (IfaceSig {tcdType = ty}) = extractHsTyNames ty get_gates is_used (ClassDecl { tcdCtxt = ctxt, tcdName = cls, tcdTyVars = tvs, tcdSigs = sigs}) - = (delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) - (hsTyVarNames tvs) - `addOneToNameSet` cls) - `plusFV` implicitGates cls + = (super_cls_and_sigs `addOneToNameSet` cls) `unionNameSets` + implicitClassGates cls where + super_cls_and_sigs = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) sigs) + (hsTyVarNames tvs) get (ClassOpSig n _ ty _) | is_used n = extractHsTyNames ty | otherwise = emptyFVs @@ -522,6 +533,22 @@ get_gates is_used (TyData {tcdCtxt = ctxt, tcdName = tycon, tcdTyVars = tvs, tcd | otherwise = emptyFVs get_bang bty = extractHsTyNames (getBangType bty) + +implicitClassGates :: Name -> FreeVars +implicitClassGates cls + -- If we load class Num, add Integer to the free gates + -- This takes account of the fact that Integer might be needed for + -- defaulting, but we don't want to load Integer (and all its baggage) + -- if there's no numeric stuff needed. + -- Similarly for class Fractional and Double + -- + -- NB: adding T to the gates will force T to be loaded + -- + -- NB: If we load (say) Floating, we'll end up loading Fractional too, + -- since Fractional is a superclass of Floating + | cls `hasKey` numClassKey = unitFV integerTyConName + | cls `hasKey` fractionalClassKey = unitFV doubleTyConName + | otherwise = emptyFVs \end{code} @getWiredInGates@ is just like @getGates@, but it sees a previously-loaded @@ -539,8 +566,11 @@ getWiredInGates :: TyThing -> FreeVars -- mentioned in other modules, and hence are in the type environment getWiredInGates (AnId the_id) = namesOfType (idType the_id) -getWiredInGates (AClass cl) = emptyFVs -- The superclasses must also be previously - -- loaded, and hence are automatically gates +getWiredInGates (AClass cl) = implicitClassGates (getName cl) + -- The superclasses must also be previously + -- loaded, and hence are automatically gates + -- All previously-loaded classes are automatically gates + -- See "The gating story" above getWiredInGates (ATyCon tc) | isSynTyCon tc = delListFromNameSet (namesOfType ty) (map getName tyvars) | otherwise = unitFV (getName tc) @@ -568,8 +598,9 @@ getImportedInstDecls gates getIfacesRn `thenRn` \ ifaces -> getTypeEnvRn `thenRn` \ lookup -> let - available n = n `elemNameSet` gates - || case lookup n of { Just (AClass c) -> True; other -> False } + available n + | n `elemNameSet` gates = True + | otherwise = case lookup n of { Just (AClass c) -> True; other -> False } -- See "The gating story" above for the AClass thing (decls, new_insts) = selectGated available (iInsts ifaces)