From 4102e5cec12cd96f59260aee2c6da01616b97467 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 25 Oct 2000 07:09:54 +0000 Subject: [PATCH] [project @ 2000-10-25 07:09:52 by simonpj] More renamer stuff; still in flight --- ghc/compiler/basicTypes/MkId.lhs | 2 +- ghc/compiler/basicTypes/NameSet.lhs | 37 ++- ghc/compiler/basicTypes/RdrName.lhs | 4 +- ghc/compiler/basicTypes/VarSet.lhs | 12 +- ghc/compiler/hsSyn/HsCore.lhs | 9 +- ghc/compiler/hsSyn/HsDecls.lhs | 7 +- ghc/compiler/main/HscTypes.lhs | 7 +- ghc/compiler/rename/Rename.lhs | 454 +++++++----------------------- ghc/compiler/rename/RnBinds.lhs | 29 +- ghc/compiler/rename/RnEnv.lhs | 19 -- ghc/compiler/rename/RnExpr.lhs | 23 +- ghc/compiler/rename/RnHiFiles.lhs | 35 +++ ghc/compiler/rename/RnHsSyn.lhs | 111 ++++++++ ghc/compiler/rename/RnIfaces.lhs | 336 +++++++++++++++++++--- ghc/compiler/rename/RnSource.hi-boot | 14 +- ghc/compiler/rename/RnSource.lhs | 498 ++++++++++++++++----------------- ghc/compiler/simplCore/SimplCore.lhs | 2 +- ghc/compiler/specialise/Rules.lhs | 76 +++-- ghc/compiler/typecheck/TcClassDcl.lhs | 23 +- ghc/compiler/typecheck/TcMonoType.lhs | 5 +- ghc/compiler/typecheck/TcRules.lhs | 7 +- ghc/compiler/types/Generics.lhs | 14 +- 22 files changed, 950 insertions(+), 774 deletions(-) diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 1d3ebc1..022877c 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -570,7 +570,7 @@ mkPrimOpId prim_op `setArityInfo` exactArity arity `setStrictnessInfo` strict_info - rules = addRule id emptyCoreRules (primOpRule prim_op) + rules = addRule emptyCoreRules id (primOpRule prim_op) -- For each ccall we manufacture a separate CCallOpId, giving it diff --git a/ghc/compiler/basicTypes/NameSet.lhs b/ghc/compiler/basicTypes/NameSet.lhs index e09bfac..ad313f7 100644 --- a/ghc/compiler/basicTypes/NameSet.lhs +++ b/ghc/compiler/basicTypes/NameSet.lhs @@ -9,7 +9,11 @@ module NameSet ( NameSet, emptyNameSet, unitNameSet, mkNameSet, unionNameSets, unionManyNameSets, minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, - delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet + delFromNameSet, delListFromNameSet, isEmptyNameSet, foldNameSet, filterNameSet, + + -- Free variables + FreeVars, isEmptyFVs, emptyFVs, plusFVs, plusFV, + mkFVs, addOneFV, unitFV, delFV, delFVs ) where #include "HsVersions.h" @@ -62,3 +66,34 @@ delListFromNameSet set ns = foldl delFromNameSet set ns \end{code} +%************************************************************************ +%* * +\subsection{Free variables} +%* * +%************************************************************************ + +These synonyms are useful when we are thinking of free variables + +\begin{code} +type FreeVars = NameSet + +plusFV :: FreeVars -> FreeVars -> FreeVars +addOneFV :: FreeVars -> Name -> FreeVars +unitFV :: Name -> FreeVars +emptyFVs :: FreeVars +plusFVs :: [FreeVars] -> FreeVars +mkFVs :: [Name] -> FreeVars +delFV :: Name -> FreeVars -> FreeVars +delFVs :: [Name] -> FreeVars -> FreeVars + +isEmptyFVs = isEmptyNameSet +emptyFVs = emptyNameSet +plusFVs = unionManyNameSets +plusFV = unionNameSets +mkFVs = mkNameSet +addOneFV = addOneToNameSet +unitFV = unitNameSet +delFV n s = delFromNameSet s n +delFVs ns s = delListFromNameSet s ns +\end{code} + diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index a438c65..a40b051 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -22,7 +22,7 @@ module RdrName ( -- Environment RdrNameEnv, emptyRdrEnv, lookupRdrEnv, addListToRdrEnv, rdrEnvElts, - extendRdrEnv, rdrEnvToList, + extendRdrEnv, rdrEnvToList, elemRdrEnv, -- Printing; instance Outputable RdrName pprUnqualRdrName @@ -185,6 +185,7 @@ addListToRdrEnv :: RdrNameEnv a -> [(RdrName,a)] -> RdrNameEnv a extendRdrEnv :: RdrNameEnv a -> RdrName -> a -> RdrNameEnv a rdrEnvToList :: RdrNameEnv a -> [(RdrName, a)] rdrEnvElts :: RdrNameEnv a -> [a] +elemRdrEnv :: RdrName -> RdrNameEnv a -> Bool emptyRdrEnv = emptyFM lookupRdrEnv = lookupFM @@ -192,4 +193,5 @@ addListToRdrEnv = addListToFM rdrEnvElts = eltsFM extendRdrEnv = addToFM rdrEnvToList = fmToList +elemRdrEnv = elemFM \end{code} diff --git a/ghc/compiler/basicTypes/VarSet.lhs b/ghc/compiler/basicTypes/VarSet.lhs index 261426e..03ec1ea 100644 --- a/ghc/compiler/basicTypes/VarSet.lhs +++ b/ghc/compiler/basicTypes/VarSet.lhs @@ -7,7 +7,7 @@ module VarSet ( VarSet, IdSet, TyVarSet, UVarSet, emptyVarSet, unitVarSet, mkVarSet, - extendVarSet, + extendVarSet, extendVarSet_C, elemVarSet, varSetElems, subVarSet, unionVarSet, unionVarSets, intersectVarSet, intersectsVarSet, @@ -18,12 +18,10 @@ module VarSet ( #include "HsVersions.h" -import CmdLineOpts ( opt_PprStyle_Debug ) -import Var ( Var, Id, TyVar, UVar, setVarUnique ) -import Unique ( Unique, Uniquable(..) ) +import Var ( Var, Id, TyVar, UVar ) +import Unique ( Unique ) import UniqSet -import UniqFM ( delFromUFM_Directly ) -import Outputable +import UniqFM ( delFromUFM_Directly, addToUFM_C ) \end{code} %************************************************************************ @@ -59,6 +57,7 @@ mapVarSet :: (Var -> Var) -> VarSet -> VarSet sizeVarSet :: VarSet -> Int filterVarSet :: (Var -> Bool) -> VarSet -> VarSet subVarSet :: VarSet -> VarSet -> Bool +extendVarSet_C :: (Var->Var->Var) -> VarSet -> Var -> VarSet delVarSetByKey :: VarSet -> Unique -> VarSet @@ -80,6 +79,7 @@ lookupVarSet = lookupUniqSet mapVarSet = mapUniqSet sizeVarSet = sizeUniqSet filterVarSet = filterUniqSet +extendVarSet_C combine s x = addToUFM_C combine s x x a `subVarSet` b = isEmptyVarSet (a `minusVarSet` b) delVarSetByKey = delFromUFM_Directly -- Can't be bothered to add this to UniqSet \end{code} diff --git a/ghc/compiler/hsSyn/HsCore.lhs b/ghc/compiler/hsSyn/HsCore.lhs index 8a02b6d..c2bd453 100644 --- a/ghc/compiler/hsSyn/HsCore.lhs +++ b/ghc/compiler/hsSyn/HsCore.lhs @@ -14,11 +14,11 @@ We could either use this, or parameterise @GenCoreExpr@ on @Types@ and module HsCore ( UfExpr(..), UfAlt, UfBinder(..), UfNote(..), UfBinding(..), UfConAlt(..), - HsIdInfo(..), pprHsIdInfo, + HsIdInfo(..), pprHsIdInfo, eq_ufExpr, eq_ufBinders, pprUfExpr, - toUfExpr, toUfBndr + toUfExpr, toUfBndr, ufBinderName ) where #include "HsVersions.h" @@ -47,7 +47,6 @@ import DataCon ( dataConTyCon ) import TyCon ( isTupleTyCon, tupleTyConBoxity ) import Type ( Kind ) import CostCentre -import SrcLoc ( SrcLoc ) import Outputable \end{code} @@ -92,6 +91,10 @@ data UfBinding name data UfBinder name = UfValBinder name (HsType name) | UfTyBinder name Kind + +ufBinderName :: UfBinder name -> name +ufBinderName (UfValBinder n _) = n +ufBinderName (UfTyBinder n _) = n \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index c49a3c5..26fd7bb 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -16,7 +16,7 @@ module HsDecls ( DeprecDecl(..), DeprecTxt, hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule, - mkClassDeclSysNames, + mkClassDeclSysNames, isIfaceRuleDecl, getClassDeclSysNames ) where @@ -237,7 +237,6 @@ mkClassDeclSysNames (a,b,c,ds) = a:b:c:ds getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) \end{code} - \begin{code} isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool @@ -373,7 +372,7 @@ data ConDecl name name -- Name of the constructor's 'worker Id' -- Filled in as the ConDecl is built - [HsTyVarBndr name] -- Existentially quantified type variables + [HsTyVarBndr name] -- Existentially quantified type variables (HsContext name) -- ...and context -- If both are empty then there are no existentials @@ -632,6 +631,8 @@ data RuleDecl name pat name -- Head of LHS CoreRule +isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False +isIfaceRuleDecl other = True data RuleBndr name = RuleBndr name diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 02da223..99b07b8 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -52,6 +52,7 @@ import OccName ( OccName ) import Module ( Module, ModuleName, ModuleEnv, lookupModuleEnv, lookupModuleEnvByName ) +import Rules ( RuleBase ) import VarSet ( TyVarSet ) import VarEnv ( emptyVarEnv ) import Id ( Id ) @@ -149,7 +150,7 @@ data ModDetails -- The next three fields are created by the typechecker md_types :: TypeEnv, md_insts :: [DFunId], -- Dfun-ids for the instances in this module - md_rules :: RuleBase -- Domain may include Ids from other modules + md_rules :: [(Id,CoreRule)] -- Domain may include Ids from other modules } \end{code} @@ -158,7 +159,7 @@ emptyModDetails :: ModDetails emptyModDetails = ModDetails { md_types = emptyTypeEnv, md_insts = [], - md_rules = emptyRuleBase + md_rules = [] } emptyModIface :: Module -> ModIface @@ -386,7 +387,7 @@ data PersistentCompilerState pcs_insts :: PackageInstEnv, -- The total InstEnv accumulated from all -- the non-home-package modules - pcs_rules :: PackageRuleEnv, -- Ditto RuleEnv + pcs_rules :: PackageRuleBase, -- Ditto RuleEnv pcs_PRS :: PersistentRenamerState } diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 690b377..201a631 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -13,17 +13,16 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, - extractHsTyNames, extractHsCtxtTyNames + extractHsTyNames, extractHsCtxtTyNames, + instDeclFVs, tyClDeclFVs, ruleDeclFVs ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl ) -import RnIfaces ( getImportedInstDecls, importDecl, mkImportInfo, +import RnIfaces ( slurpImpDecls, mkImportInfo, getInterfaceExports, - getImportedRules, getSlurped, - ImportDeclResult(..), RecompileRequired, recompileRequired ) import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) @@ -91,12 +90,9 @@ renameModule :: DynFlags -> Finder renameModule dflags finder hit hst old_pcs this_module rdr_module = -- Initialise the renamer monad do { - (new_pcs, errors_found, (maybe_rn_stuff, dump_action)) + (new_pcs, errors_found, maybe_rn_stuff) <- initRn dflags finder hit hst old_pcs this_module (rename this_module rdr_module) ; - -- Dump any debugging output - dump_action ; - -- Return results. No harm in updating the PCS if errors_found then return (new_pcs, Nothing) @@ -106,7 +102,7 @@ renameModule dflags finder hit hst old_pcs this_module rdr_module \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl]), IO ()) +rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl])) rename this_module this_mod@(HsModule mod_name vers exports imports local_decls mod_deprec loc) = -- FIND THE GLOBAL NAME ENVIRONMENT getGlobalNames this_mod `thenRn` \ maybe_stuff -> @@ -114,8 +110,8 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls -- CHECK FOR EARLY EXIT case maybe_stuff of { Nothing -> -- Everything is up to date; no need to recompile further - rnDump [] [] `thenRn` \ dump_action -> - returnRn (Nothing, dump_action) ; + rnDump [] [] `thenRn_` + returnRn Nothing ; Just (gbl_env, local_gbl_env, export_avails, global_avail_env) -> @@ -150,11 +146,11 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls slurpImpDecls slurp_fvs `thenRn` \ rn_imp_decls -> -- EXIT IF ERRORS FOUND - rnDump rn_imp_decls rn_local_decls `thenRn` \ dump_action -> + rnDump rn_imp_decls rn_local_decls `thenRn_` checkErrsRn `thenRn` \ no_errs_so_far -> if not no_errs_so_far then -- Found errors already, so exit now - returnRn (Nothing, dump_action) + returnRn Nothing else -- GENERATE THE VERSION/USAGE INFO @@ -197,7 +193,8 @@ rename this_module this_mod@(HsModule mod_name vers exports imports local_decls export_avails source_fvs rn_imp_decls `thenRn_` - returnRn (Just (mod_iface, final_decls), dump_action) } + returnRn (Just (mod_iface, final_decls)) + } \end{code} @implicitFVs@ forces the renamer to slurp in some things which aren't @@ -274,296 +271,6 @@ isOrphanDecl other = False %********************************************************* %* * -\subsection{Slurping declarations} -%* * -%********************************************************* - -\begin{code} -------------------------------------------------------- -slurpImpDecls source_fvs - = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` - - -- The current slurped-set records all local things - getSlurped `thenRn` \ source_binders -> - slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> - - -- Then get everything else - closeDecls decls needed `thenRn` \ decls1 -> - - -- Finally, get any deferred data type decls - slurpDeferredDecls decls1 `thenRn` \ final_decls -> - - returnRn final_decls - -------------------------------------------------------- -slurpSourceRefs :: NameSet -- Variables defined in source - -> FreeVars -- Variables referenced in source - -> RnMG ([RenamedHsDecl], - FreeVars) -- Un-satisfied needs --- The declaration (and hence home module) of each gate has --- already been loaded - -slurpSourceRefs source_binders source_fvs - = go_outer [] -- Accumulating decls - emptyFVs -- Unsatisfied needs - emptyFVs -- Accumulating gates - (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet - where - -- The outer loop repeatedly slurps the decls for the current gates - -- 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) - - go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet - = traceRn (text "go_outer" <+> ppr refs) `thenRn_` - foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> - getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> - rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> - go_outer decls2 fvs2 (all_gates `plusFV` gates2) - (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 - - 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 - - HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (TyClD new_decl : decls, - fvs1 `plusFV` fvs, - gates `plusFV` getGates source_fvs new_decl) - -rnInstDecls decls fvs gates [] - = returnRn (decls, fvs, gates) -rnInstDecls decls fvs gates (d:ds) - = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnInstDecls (new_decl:decls) - (fvs1 `plusFV` fvs) - (gates `plusFV` getInstDeclGates new_decl) - ds -\end{code} - - -\begin{code} -------------------------------------------------------- --- closeDecls keeps going until the free-var set is empty -closeDecls decls needed - | not (isEmptyFVs needed) - = slurpDecls decls needed `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 - - | otherwise - = getImportedRules `thenRn` \ rule_decls -> - case rule_decls of - [] -> returnRn decls -- No new rules, so we are done - other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> - closeDecls decls1 needed1 - - -------------------------------------------------------- --- Augment decls with any decls needed by needed. --- Return also free vars of the new decls (only) -slurpDecls decls needed - = go decls emptyFVs (nameSetToList needed) - where - go decls fvs [] = returnRn (decls, fvs) - go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) -> - go decls1 fvs1 refs - -------------------------------------------------------- -slurpDecl decls fvs wanted_name - = importDecl wanted_name `thenRn` \ import_result -> - case import_result of - -- Found a declaration... rename it - HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> - returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs) - - -- No declaration... (wired in thing, or deferred, or already slurped) - other -> returnRn (decls, fvs) - - -------------------------------------------------------- -rnIfaceDecls :: [RenamedHsDecl] -> FreeVars - -> [(Module, RdrNameHsDecl)] - -> RnM d ([RenamedHsDecl], FreeVars) -rnIfaceDecls decls fvs [] = returnRn (decls, fvs) -rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> - rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds - -rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) -rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) -\end{code} - - -%********************************************************* -%* * -\subsection{Deferred declarations} -%* * -%********************************************************* - -The idea of deferred declarations is this. Suppose we have a function - f :: T -> Int - data T = T1 A | T2 B - data A = A1 X | A2 Y - data B = B1 P | B2 Q -Then we don't want to load T and all its constructors, and all -the types those constructors refer to, and all the types *those* -constructors refer to, and so on. That might mean loading many more -interface files than is really necessary. So we 'defer' loading T. - -But f might be strict, and the calling convention for evaluating -values of type T depends on how many constructors T has, so -we do need to load T, but not the full details of the type T. -So we load the full decl for T, but only skeleton decls for A and B: - f :: T -> Int - data T = {- 2 constructors -} - -Whether all this is worth it is moot. - -\begin{code} -slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] -slurpDeferredDecls decls = returnRn decls - -{- OMIT FOR NOW -slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] -slurpDeferredDecls decls - = getDeferredDecls `thenRn` \ def_decls -> - rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> - ASSERT( isEmptyFVs fvs ) - returnRn decls1 - -stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2)) - = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc - name1 name2)) - -- Nuke the context and constructors - -- But retain the *number* of constructors! - -- Also the tvs will have kinds on them. --} -\end{code} - - -%********************************************************* -%* * -\subsection{Extracting the `gates'} -%* * -%********************************************************* - -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. - -@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 _ _) - = extractHsTyNames ty - -getGates source_fvs (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 - - -- If we load any numeric class that doesn't have - -- Int as an instance, add Double to the gates. - -- This takes account of the fact that Double might be needed for - -- defaulting, but we don't want to load Double (and all its baggage) - -- if the more exotic classes aren't used at all. - maybe_double | nameUnique cls `elem` fractionalClassKeys - = unitFV (getName doubleTyCon) - | otherwise - = emptyFVs - -getGates source_fvs (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 _ _ _ _ _) - = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) - (hsTyVarNames tvs) - `addOneToNameSet` tycon - where - get (ConDecl n _ tvs ctxt details _) - | n `elemNameSet` source_fvs - -- If the constructor is method, get fvs from all its fields - = delListFromNameSet (get_details details `plusFV` - extractHsCtxtTyNames ctxt) - (hsTyVarNames tvs) - get (ConDecl n _ tvs ctxt (RecCon fields) _) - -- Even if the constructor isn't mentioned, the fields - -- might be, as selectors. They can't mention existentially - -- bound tyvars (typechecker checks for that) so no need for - -- the deleteListFromNameSet part - = foldr (plusFV . get_field) emptyFVs fields - - get other_con = emptyFVs - - get_details (VanillaCon tys) = plusFVs (map get_bang tys) - 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_bang bty = extractHsTyNames (getBangType bty) -\end{code} - -@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ -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_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) -\end{code} - -\begin{code} -getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty -getInstDeclGates other = emptyFVs -\end{code} - - -%********************************************************* -%* * \subsection{Fixities} %* * %********************************************************* @@ -763,6 +470,41 @@ loadHomeUsage (mod_name, orphans, is_boot, whats_imported) \end{code} + +%********************************************************* +%* * +\subsection{Closing up the interface decls} +%* * +%********************************************************* + +Suppose we discover we don't need to recompile. Then we start from the +IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need. + +\begin{code} +closeIfaceDecls :: DynFlags -> Finder + -> HomeIfaceTable -> HomeSymbolTable + -> PersistentCompilerState + -> ModIface -- Get the decls from here + -> IO (PersistentCompilerState, Bool, [RenamedHsDecl]) + -- True <=> errors happened +closeIfaceDecls dflags finder hit hst pcs mod + mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) + = initRn dflags finder hit hst pcs mod $ + + let + rule_decls = dcl_rules iface_decls + inst_decls = dcl_insts iface_decls + tycl_decls = dcl_tycl iface_decls + decls = map RuleD rule_decls ++ + map InstD inst_decls ++ + map TyClD tycl_decls + needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` + unionManyNameSets (map instDeclFVs rule_decls) `unionNameSets` + unionManyNameSets (map tyClDeclFVs rule_decls) + in + closeDecls decls needed +\end{code} + %********************************************************* %* * \subsection{Unused names} @@ -936,18 +678,22 @@ printMinimalImports mod_name imps rnDump :: [RenamedHsDecl] -- Renamed imported decls -> [RenamedHsDecl] -- Renamed local decls - -> RnMG (IO ()) + -> RnMG () rnDump imp_decls local_decls - = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> - doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> - doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> - if dump_rn_trace || dump_rn_stats || dump_rn then - getRnStats imp_decls `thenRn` \ stats_msg -> - returnRn (printErrs stats_msg >> - dumpIfSet dump_rn "Renamer:" - (vcat (map ppr (local_decls ++ imp_decls)))) - else - returnRn (return ()) + = doptRn Opt_D_dump_rn_trace `thenRn` \ dump_rn_trace -> + doptRn Opt_D_dump_rn_stats `thenRn` \ dump_rn_stats -> + doptRn Opt_D_dump_rn `thenRn` \ dump_rn -> + getIfacesRn `thenRn` \ ifaces -> + + ioToRnM (do { dumpIfSet (dump_rn_trace || dump_rn_stats || dump_rn) + "Renamer statistics" + (getRnStats imp_decls ifaces) ; + + dumpIfSet dump_rn "Renamer:" + (vcat (map ppr (local_decls ++ imp_decls))) + }) `thenRn_` + + returnRn () \end{code} @@ -958,47 +704,45 @@ rnDump imp_decls local_decls %********************************************************* \begin{code} -getRnStats :: [RenamedHsDecl] -> RnMG SDoc -getRnStats imported_decls - = getIfacesRn `thenRn` \ ifaces -> - let - n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)] - - decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), - -- Data, newtype, and class decls are in the decls_fm - -- under multiple names; the tycon/class, and each - -- constructor/class op too. - -- The 'True' selects just the 'main' decl - not (isLocallyDefined (availName avail)) - ] - - (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read - (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls - - unslurped_insts = iInsts ifaces - inst_decls_unslurped = length (bagToList unslurped_insts) - inst_decls_read = id_sp + inst_decls_unslurped - - stats = vcat - [int n_mods <+> text "interfaces read", - hsep [ int cd_sp, text "class decls imported, out of", - int cd_rd, text "read"], - hsep [ int dd_sp, text "data decls imported, out of", - int dd_rd, text "read"], - hsep [ int nd_sp, text "newtype decls imported, out of", - int nd_rd, text "read"], - hsep [int sd_sp, text "type synonym decls imported, out of", - int sd_rd, text "read"], - hsep [int vd_sp, text "value signatures imported, out of", - int vd_rd, text "read"], - hsep [int id_sp, text "instance decls imported, out of", - int inst_decls_read, text "read"], - text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) - [d | TyClD d <- imported_decls, isClassDecl d]), - text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) +getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc +getRnStats imported_decls ifaces + = hcat [text "Renamer stats: ", stats]) + where + n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)] + + decls_read = [decl | (avail, True, (_,decl)) <- nameEnvElts (iDecls ifaces), + -- Data, newtype, and class decls are in the decls_fm + -- under multiple names; the tycon/class, and each + -- constructor/class op too. + -- The 'True' selects just the 'main' decl + not (isLocallyDefined (availName avail)) + ] + + (cd_rd, dd_rd, nd_rd, sd_rd, vd_rd) = countTyClDecls decls_read + (cd_sp, dd_sp, nd_sp, sd_sp, vd_sp, id_sp) = count_decls imported_decls + + unslurped_insts = iInsts ifaces + inst_decls_unslurped = length (bagToList unslurped_insts) + inst_decls_read = id_sp + inst_decls_unslurped + + stats = vcat + [int n_mods <+> text "interfaces read", + hsep [ int cd_sp, text "class decls imported, out of", + int cd_rd, text "read"], + hsep [ int dd_sp, text "data decls imported, out of", + int dd_rd, text "read"], + hsep [ int nd_sp, text "newtype decls imported, out of", + int nd_rd, text "read"], + hsep [int sd_sp, text "type synonym decls imported, out of", + int sd_rd, text "read"], + hsep [int vd_sp, text "value signatures imported, out of", + int vd_rd, text "read"], + hsep [int id_sp, text "instance decls imported, out of", + int inst_decls_read, text "read"], + text "cls dcls slurp" <+> fsep (map (ppr . tyClDeclName) + [d | TyClD d <- imported_decls, isClassDecl d]), + text "cls dcls read" <+> fsep (map (ppr . tyClDeclName) [d | d <- decls_read, isClassDecl d])] - in - returnRn (hcat [text "Renamer stats: ", stats]) count_decls decls = (class_decls, diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index f27407a..19d2355 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -18,7 +18,7 @@ module RnBinds ( #include "HsVersions.h" -import {-# SOURCE #-} RnSource ( rnHsSigType ) +import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) import HsSyn import HsBinds ( eqHsSig, sigName, hsSigDoc ) @@ -483,11 +483,12 @@ renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate -> [RdrNameSig] -> RnMS ([RenamedSig], FreeVars) -renameSigs ok_sig [] = returnRn ([], emptyFVs) -- Common shortcut +renameSigs ok_sig [] + = returnRn ([], emptyFVs) -- Common shortcut renameSigs ok_sig sigs = -- Rename the signatures - mapFvRn renameSig sigs `thenRn` \ (sigs', fvs) -> + mapRn renameSig sigs `thenRn` \ sigs' -> -- Check for (a) duplicate signatures -- (b) signatures for things not in this group @@ -499,7 +500,7 @@ renameSigs ok_sig sigs (goods, bads) = partition ok_sig in_scope in mapRn_ unknownSigErr bads `thenRn_` - returnRn (goods, fvs) + returnRn (goods, hsSigFVs goods) -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -510,39 +511,39 @@ renameSigs ok_sig sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSig :: Sig RdrName -> RnMS (Sig Name, FreeVars) +renameSig :: Sig RdrName -> RnMS (Sig Name) -- ClassOpSig is renamed elsewhere. renameSig (Sig v ty src_loc) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> - returnRn (Sig new_v new_ty src_loc, fvs `addOneFV` new_v) + rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> + returnRn (Sig new_v new_ty src_loc) renameSig (SpecInstSig ty src_loc) = pushSrcLocRn src_loc $ - rnHsSigType (text "A SPECIALISE instance pragma") ty `thenRn` \ (new_ty, fvs) -> - returnRn (SpecInstSig new_ty src_loc, fvs) + rnHsType (text "A SPECIALISE instance pragma") ty `thenRn` \ new_ty -> + returnRn (SpecInstSig new_ty src_loc) renameSig (SpecSig v ty src_loc) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> - rnHsSigType (quotes (ppr v)) ty `thenRn` \ (new_ty,fvs) -> - returnRn (SpecSig new_v new_ty src_loc, fvs `addOneFV` new_v) + rnHsSigType (quotes (ppr v)) ty `thenRn` \ new_ty -> + returnRn (SpecSig new_v new_ty src_loc) renameSig (FixSig (FixitySig v fix src_loc)) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> - returnRn (FixSig (FixitySig new_v fix src_loc), unitFV new_v) + returnRn (FixSig (FixitySig new_v fix src_loc)) renameSig (InlineSig v p src_loc) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> - returnRn (InlineSig new_v p src_loc, unitFV new_v) + returnRn (InlineSig new_v p src_loc) renameSig (NoInlineSig v p src_loc) = pushSrcLocRn src_loc $ lookupSigOccRn v `thenRn` \ new_v -> - returnRn (NoInlineSig new_v p src_loc, unitFV new_v) + returnRn (NoInlineSig new_v p src_loc) \end{code} \begin{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index adcdb82..145c8c3 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -670,25 +670,6 @@ pprAvail (Avail n) = ppr n %************************************************************************ \begin{code} -type FreeVars = NameSet - -plusFV :: FreeVars -> FreeVars -> FreeVars -addOneFV :: FreeVars -> Name -> FreeVars -unitFV :: Name -> FreeVars -emptyFVs :: FreeVars -plusFVs :: [FreeVars] -> FreeVars -mkFVs :: [Name] -> FreeVars - -isEmptyFVs = isEmptyNameSet -emptyFVs = emptyNameSet -plusFVs = unionManyNameSets -plusFV = unionNameSets -mkFVs = mkNameSet - --- No point in adding implicitly imported names to the free-var set -addOneFV s n = addOneToNameSet s n -unitFV n = unitNameSet n - -- A useful utility mapFvRn f xs = mapRn f xs `thenRn` \ stuff -> let diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 134a540..382f429 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -18,14 +18,14 @@ module RnExpr ( #include "HsVersions.h" import {-# SOURCE #-} RnBinds ( rnBinds ) -import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType ) +import {-# SOURCE #-} RnSource ( rnHsTypeFVs ) import HsSyn import RdrHsSyn import RnHsSyn import RnMonad import RnEnv -import RnIfaces ( lookupFixityRn ) +import RnHiFiles ( lookupFixityRn ) import CmdLineOpts ( DynFlag(..), opt_IgnoreAsserts ) import Literal ( inIntRange ) import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity ) @@ -71,7 +71,7 @@ rnPat (SigPatIn pat ty) if glaExts then rnPat pat `thenRn` \ (pat', fvs1) -> - rnHsType doc ty `thenRn` \ (ty', fvs2) -> + rnHsTypeFVs doc ty `thenRn` \ (ty', fvs2) -> returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2) else addErrRn (patSigErr ty) `thenRn_` @@ -146,7 +146,7 @@ rnPat (RecPatIn con rpats) rnRpats rpats `thenRn` \ (rpats', fvs) -> returnRn (RecPatIn con' rpats', fvs `addOneFV` con') rnPat (TypePatIn name) = - (rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) -> + (rnHsTypeFVs (text "type pattern") name) `thenRn` \ (name', fvs) -> returnRn (TypePatIn name', fvs) \end{code} @@ -187,7 +187,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss) doptRn Opt_GlasgowExts `thenRn` \ opt_GlasgowExts -> (case maybe_rhs_sig of Nothing -> returnRn (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) -> + Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenRn` \ (ty', ty_fvs) -> returnRn (Just ty', ty_fvs) | otherwise -> addErrRn (patSigErr ty) `thenRn_` returnRn (Nothing, emptyFVs) @@ -411,8 +411,8 @@ rnExpr (RecordUpd expr rbinds) returnRn (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenRn` \ (expr', fvExpr) -> - rnHsSigType (text "an expression") pty `thenRn` \ (pty', fvTy) -> + = rnExpr expr `thenRn` \ (expr', fvExpr) -> + rnHsTypeFVs (text "an expression type signature") pty `thenRn` \ (pty', fvTy) -> returnRn (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) rnExpr (HsIf p b1 b2 src_loc) @@ -422,10 +422,11 @@ rnExpr (HsIf p b1 b2 src_loc) rnExpr b2 `thenRn` \ (b2', fvB2) -> returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) -rnExpr (HsType a) = - (rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT) - where doc = text "renaming a type pattern" - +rnExpr (HsType a) + = rnHsTypeFVs doc a `thenRn` \ (t, fvT) -> + returnRn (HsType t, fvT) + where + doc = text "renaming a type pattern" rnExpr (ArithSeqIn seq) = lookupOrigName enumClass_RDR `thenRn` \ enum -> diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 54c3092..6bff192 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -9,6 +9,8 @@ module RnHiFiles ( tryLoadInterface, loadOrphanModules, loadExports, loadFixDecls, loadDeprecs, + lookupFixityRn, + getTyClDeclBinders, removeContext -- removeContext probably belongs somewhere else ) where @@ -542,6 +544,39 @@ readIface wanted_mod file_path %********************************************************* +%* * +\subsection{Looking up fixities} +%* * +%********************************************************* + +This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface + +\begin{code} +lookupFixityRn :: Name -> RnMS Fixity +lookupFixityRn name + | isLocallyDefined name + = getFixityEnv `thenRn` \ local_fix_env -> + returnRn (lookupLocalFixity local_fix_env name) + + | otherwise -- Imported + -- For imported names, we have to get their fixities by doing a loadHomeInterface, + -- and consulting the Ifaces that comes back from that, because the interface + -- file for the Name might not have been loaded yet. Why not? Suppose you import module A, + -- which exports a function 'f', which is defined in module B. Then B isn't loaded + -- right away (after all, it's possible that nothing from B will be used). + -- When we come across a use of 'f', we need to know its fixity, and it's then, + -- and only then, that we load B.hi. That is what's happening here. + = getHomeIfaceTableRn `thenRn` \ hit -> + loadHomeInterface doc name `thenRn` \ ifaces -> + case lookupTable hit (iPIT ifaces) name of + Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) + Nothing -> returnRn defaultFixity + where + doc = ptext SLIT("Checking fixity for") <+> ppr name +\end{code} + + +%********************************************************* %* * \subsection{Errors} %* * diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 9642f05..64564fc 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -9,10 +9,13 @@ module RnHsSyn where #include "HsVersions.h" import HsSyn +import HsCore +import Class ( FunDep, DefMeth(..) ) import TysWiredIn ( tupleTyCon, listTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) +import Maybes ( orElse ) import Outputable \end{code} @@ -65,6 +68,9 @@ tupleTyCon_name boxity n = getName (tupleTyCon boxity n) extractHsTyVars :: RenamedHsType -> NameSet extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) +extractFunDepNames :: FunDep Name -> NameSet +extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 + extractHsTyNames :: RenamedHsType -> NameSet extractHsTyNames ty = get ty @@ -104,6 +110,111 @@ extractHsPredTyNames (HsPIParam n ty) %************************************************************************ %* * +\subsection{Free variables of declarations} +%* * +%************************************************************************ + +Return the Names that must be in scope if we are to use this declaration. +In all cases this is set up for interface-file declarations: + - for class decls we ignroe the bindings + - for instance decls likewise, plus the pragmas + - for rule decls, we ignore HsRules + +\begin{code} +tyClDeclFVs :: RenamedTyClDecl -> NameSet +tyClDeclFVs (IfaceSig name ty id_infos loc) + = extractHsTyNames ty `plusFV` + plusFVs (map hsIdInfoFVs id_infos) + +tyClDeclFVs (TyData _ context _ tyvars condecls _ derivings _ _ _) + = delFVs (map hsTyVarName tyvars) $ + extractHsCtxtTyNames context `plusFV` + plusFVs (map conDeclFVs condecls) `plusFV` + mkNameSet (derivings `orElse` []) + +tyClDeclFVs (TySynonym _ tyvars ty _) + = delFVs (map hsTyVarName tyvars) (extractHsTyNames ty) + +tyClDeclFVs (ClassDecl context _ tyvars fds sigs _ _ src_loc) + = delFVs (map hsTyVarName tyvars) $ + extractHsCtxtTyNames context `plusFV` + plusFVs (map extractFunDepNames fds) `plusFV` + plusFVs (map hsSigFVs sigs) + +---------------- +hsSigFVs (Sig v ty _) = extractHsTyNames ty `addOneFV` v +hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty +hsSigFVs (SpecSig v ty _) = extractHsTyNames ty `addOneFV` v +hsSigFVs (FixSig (FixitySig v _ _)) = unitFV v +hsSigFVs (InlineSig v p _) = unitFV v +hsSigFVs (NoInlineSig v p _) = unitFV v +hsSigFVs (ClassOpSig v dm ty _) = dmFVs dm `plusFV` extractHsTyNames ty `addOneFV` v + +dmFVs (Just (DefMeth v)) = unitFV v +dmFVs other = emptyFVs + +---------------- +instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _) + = extractHsTyNames inst_ty `plusFV` + (case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs }) + +---------------- +ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs +ruleDeclFVs (IfaceRule _ vars _ _ rhs _) + = delFVs (map ufBinderName vars) $ + ufExprFVs rhs + +---------------- +conDeclFVs (ConDecl _ _ tyvars context details _) + = delFVs (map hsTyVarName tyvars) $ + extractHsCtxtTyNames context `plusFV` + conDetailsFVs details + +conDetailsFVs (VanillaCon btys) = plusFVs (map bangTyFVs btys) +conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 +conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] + +bangTyFVs bty = extractHsTyNames (getBangType bty) + +---------------- +hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf +hsIdInfoFVs (HsWorker n) = unitFV n +hsIdInfoFVs other = emptyFVs + +---------------- +ufExprFVs (UfVar n) = unitFV n +ufExprFVs (UfLit l) = emptyFVs +ufExprFVs (UfLitLit l ty) = extractHsTyNames ty +ufExprFVs (UfCCall cc ty) = extractHsTyNames ty +ufExprFVs (UfType ty) = extractHsTyNames ty +ufExprFVs (UfTuple tc es) = hsTupConFVs tc `plusFV` plusFVs (map ufExprFVs es) +ufExprFVs (UfLam v e) = ufBndrFVs v (ufExprFVs e) +ufExprFVs (UfApp e1 e2) = ufExprFVs e1 `plusFV` ufExprFVs e2 +ufExprFVs (UfCase e n as) = ufExprFVs e `plusFV` delFV n (plusFVs (map ufAltFVs as)) +ufExprFVs (UfNote n e) = ufNoteFVs n `plusFV` ufExprFVs e +ufExprFVs (UfLet (UfNonRec b r) e) = ufExprFVs r `plusFV` ufBndrFVs b (ufExprFVs e) +ufExprFVs (UfLet (UfRec prs) e) = foldr ufBndrFVs + (foldr (plusFV . ufExprFVs . snd) (ufExprFVs e) prs) + (map fst prs) + +ufBndrFVs (UfValBinder n ty) fvs = extractHsTyNames ty `plusFV` delFV n fvs +ufBndrFVs (UfTyBinder n k) fvs = delFV n fvs + +ufAltFVs (con, vs, e) = ufConFVs con `plusFV` delFVs vs (ufExprFVs e) + +ufConFVs (UfDataAlt n) = unitFV n +ufConFVs (UfTupleAlt t) = hsTupConFVs t +ufConFVs (UfLitLitAlt _ ty) = extractHsTyNames ty +ufConFVs other = emptyFVs + +ufNoteFVs (UfCoerce ty) = extractHsTyNames ty +ufNoteFVs note = emptyFVs + +hsTupConFVs (HsTupCon n _) = unitFV n +\end{code} + +%************************************************************************ +%* * \subsection{A few functions on generic defintions %* * %************************************************************************ diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 128ee1d..8680d59 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -5,12 +5,12 @@ \begin{code} module RnIfaces - ( + ( getInterfaceExports, - getImportedInstDecls, getImportedRules, - lookupFixityRn, - importDecl, ImportDeclResult(..), recordLocalSlurps, - mkImportInfo, getSlurped, + recordLocalSlurps, + mkImportInfo, + + slurpImpDecls, RecompileRequired, outOfDate, upToDate, recompileRequired ) @@ -27,6 +27,7 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl ) import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, loadOrphanModules ) +import RnSource ( rnTyClDecl, rnDecl ) import RnEnv import RnMonad import Name ( Name {-instance NamedThing-}, nameOccName, @@ -85,39 +86,6 @@ getInterfaceExports mod_name from %* * %********************************************************* -This has to be in RnIfaces (or RnHiFiles) because it calls loadHomeInterface - -\begin{code} -lookupFixityRn :: Name -> RnMS Fixity -lookupFixityRn name - | isLocallyDefined name - = getFixityEnv `thenRn` \ local_fix_env -> - returnRn (lookupLocalFixity local_fix_env name) - - | otherwise -- Imported - -- For imported names, we have to get their fixities by doing a loadHomeInterface, - -- and consulting the Ifaces that comes back from that, because the interface - -- file for the Name might not have been loaded yet. Why not? Suppose you import module A, - -- which exports a function 'f', which is defined in module B. Then B isn't loaded - -- right away (after all, it's possible that nothing from B will be used). - -- When we come across a use of 'f', we need to know its fixity, and it's then, - -- and only then, that we load B.hi. That is what's happening here. - = getHomeIfaceTableRn `thenRn` \ hit -> - loadHomeInterface doc name `thenRn` \ ifaces -> - case lookupTable hit (iPIT ifaces) name of - Just iface -> returnRn (lookupNameEnv (mi_fixities iface) name `orElse` defaultFixity) - Nothing -> returnRn defaultFixity - where - doc = ptext SLIT("Checking fixity for") <+> ppr name -\end{code} - - -%********************************************************* -%* * -\subsection{Instance declarations are handled specially} -%* * -%********************************************************* - \begin{code} getImportedInstDecls :: NameSet -> RnMG [(Module,RdrNameHsDecl)] getImportedInstDecls gates @@ -347,6 +315,145 @@ addItem fm mod x = extendModuleEnv_C add_item fm mod [x] add_item xs _ = x:xs \end{code} +%********************************************************* +%* * +\subsection{Slurping declarations} +%* * +%********************************************************* + +\begin{code} +------------------------------------------------------- +slurpImpDecls source_fvs + = traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_` + + -- The current slurped-set records all local things + getSlurped `thenRn` \ source_binders -> + slurpSourceRefs source_binders source_fvs `thenRn` \ (decls, needed) -> + + -- Then get everything else + closeDecls decls needed `thenRn` \ decls1 -> + + -- Finally, get any deferred data type decls + slurpDeferredDecls decls1 `thenRn` \ final_decls -> + + returnRn final_decls + + +------------------------------------------------------- +slurpSourceRefs :: NameSet -- Variables defined in source + -> FreeVars -- Variables referenced in source + -> RnMG ([RenamedHsDecl], + FreeVars) -- Un-satisfied needs +-- The declaration (and hence home module) of each gate has +-- already been loaded + +slurpSourceRefs source_binders source_fvs + = go_outer [] -- Accumulating decls + emptyFVs -- Unsatisfied needs + emptyFVs -- Accumulating gates + (nameSetToList source_fvs) -- Things whose defn hasn't been loaded yet + where + -- The outer loop repeatedly slurps the decls for the current gates + -- 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) + + go_outer decls fvs all_gates refs -- refs are not necessarily slurped yet + = traceRn (text "go_outer" <+> ppr refs) `thenRn_` + foldlRn go_inner (decls, fvs, emptyFVs) refs `thenRn` \ (decls1, fvs1, gates1) -> + getImportedInstDecls (all_gates `plusFV` gates1) `thenRn` \ inst_decls -> + rnInstDecls decls1 fvs1 gates1 inst_decls `thenRn` \ (decls2, fvs2, gates2) -> + go_outer decls2 fvs2 (all_gates `plusFV` gates2) + (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 + + 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 + + HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (TyClD new_decl : decls, + fvs1 `plusFV` fvs, + gates `plusFV` getGates source_fvs new_decl) + +rnInstDecls decls fvs gates [] + = returnRn (decls, fvs, gates) +rnInstDecls decls fvs gates (d:ds) + = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> + rnInstDecls (new_decl:decls) + (fvs1 `plusFV` fvs) + (gates `plusFV` getInstDeclGates new_decl) + ds +\end{code} + + +\begin{code} +------------------------------------------------------- +-- closeDecls keeps going until the free-var set is empty +closeDecls decls needed + | not (isEmptyFVs needed) + = slurpDecls decls needed `thenRn` \ (decls1, needed1) -> + closeDecls decls1 needed1 + + | otherwise + = getImportedRules `thenRn` \ rule_decls -> + case rule_decls of + [] -> returnRn decls -- No new rules, so we are done + other -> rnIfaceDecls decls emptyFVs rule_decls `thenRn` \ (decls1, needed1) -> + closeDecls decls1 needed1 + + +------------------------------------------------------- +-- Augment decls with any decls needed by needed. +-- Return also free vars of the new decls (only) +slurpDecls decls needed + = go decls emptyFVs (nameSetToList needed) + where + go decls fvs [] = returnRn (decls, fvs) + go decls fvs (ref:refs) = slurpDecl decls fvs ref `thenRn` \ (decls1, fvs1) -> + go decls1 fvs1 refs + +------------------------------------------------------- +slurpDecl decls fvs wanted_name + = importDecl wanted_name `thenRn` \ import_result -> + case import_result of + -- Found a declaration... rename it + HereItIs decl -> rnIfaceTyClDecl decl `thenRn` \ (new_decl, fvs1) -> + returnRn (TyClD new_decl:decls, fvs1 `plusFV` fvs) + + -- No declaration... (wired in thing, or deferred, or already slurped) + other -> returnRn (decls, fvs) + + +------------------------------------------------------- +rnIfaceDecls :: [RenamedHsDecl] -> FreeVars + -> [(Module, RdrNameHsDecl)] + -> RnM d ([RenamedHsDecl], FreeVars) +rnIfaceDecls decls fvs [] = returnRn (decls, fvs) +rnIfaceDecls decls fvs (d:ds) = rnIfaceDecl d `thenRn` \ (new_decl, fvs1) -> + rnIfaceDecls (new_decl:decls) (fvs1 `plusFV` fvs) ds + +rnIfaceDecl (mod, decl) = initIfaceRnMS mod (rnDecl decl) +rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) +\end{code} + + \begin{code} getSlurped = getIfacesRn `thenRn` \ ifaces -> @@ -369,6 +476,159 @@ recordLocalSlurps local_avails \end{code} + +%********************************************************* +%* * +\subsection{Deferred declarations} +%* * +%********************************************************* + +The idea of deferred declarations is this. Suppose we have a function + f :: T -> Int + data T = T1 A | T2 B + data A = A1 X | A2 Y + data B = B1 P | B2 Q +Then we don't want to load T and all its constructors, and all +the types those constructors refer to, and all the types *those* +constructors refer to, and so on. That might mean loading many more +interface files than is really necessary. So we 'defer' loading T. + +But f might be strict, and the calling convention for evaluating +values of type T depends on how many constructors T has, so +we do need to load T, but not the full details of the type T. +So we load the full decl for T, but only skeleton decls for A and B: + f :: T -> Int + data T = {- 2 constructors -} + +Whether all this is worth it is moot. + +\begin{code} +slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] +slurpDeferredDecls decls = returnRn decls + +{- OMIT FOR NOW +slurpDeferredDecls :: [RenamedHsDecl] -> RnMG [RenamedHsDecl] +slurpDeferredDecls decls + = getDeferredDecls `thenRn` \ def_decls -> + rnIfaceDecls decls emptyFVs (map stripDecl def_decls) `thenRn` \ (decls1, fvs) -> + ASSERT( isEmptyFVs fvs ) + returnRn decls1 + +stripDecl (mod, TyClD (TyData dt _ tc tvs _ nconstrs _ loc name1 name2)) + = (mod, TyClD (TyData dt [] tc tvs [] nconstrs Nothing loc + name1 name2)) + -- Nuke the context and constructors + -- But retain the *number* of constructors! + -- Also the tvs will have kinds on them. +-} +\end{code} + + +%********************************************************* +%* * +\subsection{Extracting the `gates'} +%* * +%********************************************************* + +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. + +@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 _ _) + = extractHsTyNames ty + +getGates source_fvs (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 + + -- If we load any numeric class that doesn't have + -- Int as an instance, add Double to the gates. + -- This takes account of the fact that Double might be needed for + -- defaulting, but we don't want to load Double (and all its baggage) + -- if the more exotic classes aren't used at all. + maybe_double | nameUnique cls `elem` fractionalClassKeys + = unitFV (getName doubleTyCon) + | otherwise + = emptyFVs + +getGates source_fvs (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 _ _ _ _ _) + = delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons) + (hsTyVarNames tvs) + `addOneToNameSet` tycon + where + get (ConDecl n _ tvs ctxt details _) + | n `elemNameSet` source_fvs + -- If the constructor is method, get fvs from all its fields + = delListFromNameSet (get_details details `plusFV` + extractHsCtxtTyNames ctxt) + (hsTyVarNames tvs) + get (ConDecl n _ tvs ctxt (RecCon fields) _) + -- Even if the constructor isn't mentioned, the fields + -- might be, as selectors. They can't mention existentially + -- bound tyvars (typechecker checks for that) so no need for + -- the deleteListFromNameSet part + = foldr (plusFV . get_field) emptyFVs fields + + get other_con = emptyFVs + + get_details (VanillaCon tys) = plusFVs (map get_bang tys) + 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_bang bty = extractHsTyNames (getBangType bty) +\end{code} + +@getWiredInGates@ is just like @getGates@, but it sees a wired-in @Name@ +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_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names) +\end{code} + +\begin{code} +getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty +getInstDeclGates other = emptyFVs +\end{code} + + %********************************************************* %* * \subsection{Getting in a declaration} diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot index 399a3c9..3d9bfa2 100644 --- a/ghc/compiler/rename/RnSource.hi-boot +++ b/ghc/compiler/rename/RnSource.hi-boot @@ -1,11 +1,11 @@ -_interface_ RnSource 1 +_interface_ RnSource 2 _exports_ -RnSource rnHsType rnHsPolyType rnHsSigType; +RnSource rnHsType rnHsSigType rnHsTypeFVs; _declarations_ -1 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType +1 rnHsTypeFVs _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; -1 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; -1 rnHsPolyType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; +2 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS RnHsSyn.RenamedHsType ;; +2 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType + -> RnMonad.RnMS RnHsSyn.RenamedHsType ;; diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index e3ceb96..eed6188 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,8 +4,8 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, - rnSourceDecls, rnHsType, rnHsSigType +module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, rnSourceDecls, + rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs ) where #include "HsVersions.h" @@ -13,7 +13,7 @@ module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, import RnExpr import HsSyn import HsTypes ( hsTyVarNames, pprHsContext ) -import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr ) +import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars @@ -33,11 +33,9 @@ import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, ) import RnMonad -import FunDeps ( oclose ) import Class ( FunDep, DefMeth (..) ) import Name ( Name, OccName, nameOccName, NamedThing(..) ) import NameSet -import FiniteMap ( elemFM ) import PrelInfo ( derivableClassKeys, cCallishClassKeys ) import PrelNames ( deRefStablePtr_RDR, makeStablePtr_RDR, bindIO_RDR, returnIO_RDR @@ -104,20 +102,26 @@ rnDecl :: RdrNameHsDecl -> RnMS (RenamedHsDecl, FreeVars) rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> returnRn (ValD new_binds, fvs) -rnDecl (TyClD tycl_decl) = rnTyClDecl tycl_decl `thenRn` \ (new_decl, fvs) -> - returnRn (TyClD new_decl, fvs) - -rnDecl (RuleD rule) - = rnRuleDecl rule `thenRn` \ (new_rule, fvs) -> - returnRn (RuleD new_rule, fvs) +rnDecl (TyClD tycl_decl) + = rnTyClDecl tycl_decl `thenRn` \ new_decl -> + rnClassBinds new_decl `thenRn` \ (new_decl', fvs) -> + returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') rnDecl (InstD inst) - = rnInstDecl inst `thenRn` \ (new_inst, fvs) -> - returnRn (InstD new_inst, fvs) + = rnInstDecl inst `thenRn` \ new_inst -> + rnInstBinds new_inst `thenRn` \ (new_inst', fvs) + returnRn (InstD new_inst, fvs `plusFV` instDeclFVs new_inst') + +rnDecl (RuleD rule) + | isIfaceRuleDecl rule + = rnIfaceRuleDecl rule `thenRn` \ new_rule -> + returnRn (RuleD new_rule, ruleDeclFVs new_rule) + | otherwise + = rnHsRuleDecl rule rnDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ - rnHsTypes doc_str tys `thenRn` \ (tys', fvs) -> + mapFvRn (rnHsTypeFVs doc_str) tys `thenRn` \ (tys', fvs) -> returnRn (DefD (DefaultDecl tys' src_loc), fvs) where doc_str = text "a `default' declaration" @@ -138,11 +142,11 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) extra_fvs imp_exp `thenRn` \ fvs1 -> - rnHsSigType fo_decl_msg ty `thenRn` \ (ty', fvs2) -> + rnHsTypeFVs fo_decl_msg ty `thenRn` \ (ty', fvs2) -> returnRn (ForD (ForeignDecl name' imp_exp ty' ext_nm cconv src_loc), fvs1 `plusFV` fvs2) where - fo_decl_msg = ptext SLIT("a foreign declaration") + fo_decl_msg = ptext SLIT("The foreign declaration for") <+> ppr name isDyn = isDynamicExtName ext_nm ok_ext_nm Dynamic = True @@ -160,9 +164,25 @@ rnDecl (ForD (ForeignDecl name imp_exp ty ext_nm cconv src_loc)) \begin{code} rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) = pushSrcLocRn src_loc $ - rnHsSigType (text "an instance decl") inst_ty `thenRn` \ (inst_ty', inst_fvs) -> - let - inst_tyvars = case inst_ty' of + rnHsSigType (text "an instance decl") inst_ty `thenRn` \ inst_ty' -> + + (case maybe_dfun_rdr_name of + Nothing -> returnRn Nothing + Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name -> + returnRn (Just dfun_name) + ) `thenRn` \ maybe_dfun_name -> + + -- The typechecker checks that all the bindings are for the right class. + returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc) + where + meth_doc = text "the bindings in an instance declaration" + meth_names = collectLocatedMonoBinders mbinds + +-- Compare rnClassBinds +rnInstBinds (InstDecl _ mbinds uprags _ _ ) + (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) + = let + inst_tyvars = case inst_ty of HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars other -> [] -- (Slightly strangely) the forall-d tyvars scope over @@ -188,21 +208,10 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) -- But the (unqualified) method names are in scope bindLocalNames binders ( renameSigs (okInstDclSig binder_set) uprags - ) `thenRn` \ (new_uprags, prag_fvs) -> + ) `thenRn` \ (uprags', prag_fvs) -> - (case maybe_dfun_rdr_name of - Nothing -> returnRn (Nothing, emptyFVs) - - Just dfun_rdr_name -> lookupSysBinder dfun_rdr_name `thenRn` \ dfun_name -> - returnRn (Just dfun_name, unitFV dfun_name) - ) `thenRn` \ (maybe_dfun_name, dfun_fv) -> - - -- The typechecker checks that all the bindings are for the right class. - returnRn (InstDecl inst_ty' mbinds' new_uprags maybe_dfun_name src_loc, - inst_fvs `plusFV` meth_fvs `plusFV` prag_fvs `plusFV` dfun_fv) - where - meth_doc = text "the bindings in an instance declaration" - meth_names = collectLocatedMonoBinders mbinds + returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc, + meth_fvs `plusFV` prag_fvs) \end{code} %********************************************************* @@ -212,16 +221,15 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) %********************************************************* \begin{code} -rnRuleDecl (IfaceRule rule_name vars fn args rhs src_loc) +rnIfaceRuleDecl (IfaceRule rule_name vars fn args rhs src_loc) = pushSrcLocRn src_loc $ lookupOccRn fn `thenRn` \ fn' -> rnCoreBndrs vars $ \ vars' -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs1) -> - rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> - returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc, - (fvs1 `plusFV` fvs2) `addOneFV` fn') + mapFvRn rnCoreExpr args `thenRn` \ args' -> + rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc) -rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) +rnHsRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) = ASSERT( null tvs ) pushSrcLocRn src_loc $ @@ -247,7 +255,7 @@ rnRuleDecl (HsRule rule_name tvs vars lhs rhs src_loc) get_var (RuleBndrSig v _) = v rn_var (RuleBndr v, id) = returnRn (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsType doc t `thenRn` \ (t', fvs) -> + rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenRn` \ (t', fvs) -> returnRn (RuleBndrSig id t', fvs) \end{code} @@ -275,25 +283,24 @@ However, we can also do some scoping checks at the same time. rnTyClDecl (IfaceSig name ty id_infos loc) = pushSrcLocRn loc $ lookupTopBndrRn name `thenRn` \ name' -> - rnHsType doc_str ty `thenRn` \ (ty',fvs1) -> - mapFvRn rnIdInfo id_infos `thenRn` \ (id_infos', fvs2) -> - returnRn (IfaceSig name' ty' id_infos' loc, fvs1 `plusFV` fvs2) + rnHsType doc_str ty `thenRn` \ ty' -> + mapRn rnIdInfo id_infos `thenRn` \ id_infos' -> + returnRn (IfaceSig name' ty' id_infos' loc) where doc_str = text "the interface signature for" <+> quotes (ppr name) rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings src_loc gen_name1 gen_name2) = pushSrcLocRn src_loc $ lookupTopBndrRn tycon `thenRn` \ tycon' -> - bindTyVarsFVRn data_doc tyvars $ \ tyvars' -> - rnContext data_doc context `thenRn` \ (context', cxt_fvs) -> + bindTyVarsRn data_doc tyvars $ \ tyvars' -> + rnContext data_doc context `thenRn` \ context' -> checkDupOrQualNames data_doc con_names `thenRn_` - mapFvRn rnConDecl condecls `thenRn` \ (condecls', con_fvs) -> + mapFvRn rnConDecl condecls `thenRn` \ condecls' -> lookupSysBinder gen_name1 `thenRn` \ name1' -> lookupSysBinder gen_name2 `thenRn` \ name2' -> - rnDerivs derivings `thenRn` \ (derivings', deriv_fvs) -> + rnDerivs derivings `thenRn` \ derivings' -> returnRn (TyData new_or_data context' tycon' tyvars' condecls' nconstrs - derivings' src_loc name1' name2', - cxt_fvs `plusFV` con_fvs `plusFV` deriv_fvs) + derivings' src_loc name1' name2') where data_doc = text "the data type declaration for" <+> quotes (ppr tycon) con_names = map conDeclName condecls @@ -302,9 +309,9 @@ rnTyClDecl (TySynonym name tyvars ty src_loc) = pushSrcLocRn src_loc $ doptRn Opt_GlasgowExts `thenRn` \ glaExts -> lookupTopBndrRn name `thenRn` \ name' -> - bindTyVarsFVRn syn_doc tyvars $ \ tyvars' -> - rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) -> - returnRn (TySynonym name' tyvars' ty' src_loc, ty_fvs) + bindTyVarsRn syn_doc tyvars $ \ tyvars' -> + rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ ty' -> + returnRn (TySynonym name' tyvars' ty' src_loc) where syn_doc = text "the declaration for type synonym" <+> quotes (ppr name) @@ -322,20 +329,16 @@ rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) -- They aren't in scope (because they aren't visible to the user) -- and what we want to do is simply look them up in the cache; -- we jolly well ought to get a 'hit' there! - -- So the 'Imported' part of this call is not relevant. - -- Unclean; but since these two are the only place this happens - -- I can't work up the energy to do it more beautifully - - mapRn lookupSysBinder names `thenRn` \ names' -> + mapRn lookupSysBinder names `thenRn` \ names' -> -- Tyvars scope over bindings and context - bindTyVarsFV2Rn cls_doc tyvars ( \ clas_tyvar_names tyvars' -> + bindTyVars2Rn cls_doc tyvars $ \ clas_tyvar_names tyvars' -> -- Check the superclasses - rnContext cls_doc context `thenRn` \ (context', cxt_fvs) -> + rnContext cls_doc context `thenRn` \ context' -> -- Check the functional dependencies - rnFds cls_doc fds `thenRn` \ (fds', fds_fvs) -> + rnFds cls_doc fds `thenRn` \ fds' -> -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). @@ -343,15 +346,55 @@ rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) (op_sigs, non_op_sigs) = partition isClassOpSig sigs sig_rdr_names_w_locs = [(op,locn) | ClassOpSig op _ _ locn <- sigs] in - checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` - mapFvRn (rn_op cname' clas_tyvar_names fds') op_sigs `thenRn` \ (sigs', sig_fvs) -> + checkDupOrQualNames sig_doc sig_rdr_names_w_locs `thenRn_` + mapRn (rnClassOp cname' clas_tyvar_names fds') op_sigs `thenRn` \ sigs' -> let binders = mkNameSet [ nm | (ClassOpSig nm _ _ _) <- sigs' ] in - renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ (non_ops', fix_fvs) -> + renameSigs (okClsDclSig binders) non_op_sigs `thenRn` \ non_ops' -> - -- Check the methods - -- The newLocals call is tiresome: given a generic class decl + -- Typechecker is responsible for checking that we only + -- give default-method bindings for things in this class. + -- The renamer *could* check this for class decls, but can't + -- for instance decls. + + returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' names' src_loc) + where + cls_doc = text "the declaration for class" <+> ppr cname + sig_doc = text "the signatures for class" <+> ppr cname + meth_doc = text "the default-methods for class" <+> ppr cname + +rnClassOp clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn) + = pushSrcLocRn locn $ + lookupTopBndrRn op `thenRn` \ op_name -> + + -- Check the signature + rnHsSigType (quotes (ppr op)) ty `thenRn` \ new_ty -> + + -- Make the default-method name + (case maybe_dm_stuff of + Nothing -> returnRn Nothing -- Source-file class decl + + Just (DefMeth dm_rdr_name) + -> -- Imported class that has a default method decl + -- See comments with tname, snames, above + lookupSysBinder dm_rdr_name `thenRn` \ dm_name -> + returnRn (Just (DefMeth dm_name)) + -- An imported class decl for a class decl that had an explicit default + -- method, mentions, rather than defines, + -- the default method, so we must arrange to pull it in + + Just GenDefMeth -> returnRn (Just GenDefMeth) + Just NoDefMeth -> returnRn (Just NoDefMeth) + ) `thenRn` \ maybe_dm_stuff' -> + + returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn) + +rnClassBinds :: RdrNameTyClDecl -> RenamedTyClDecl -> RnMS (RenamedTyClDecl, FreeVars) + -- Rename the mbinds only; the rest is done already +rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- Get mbinds from here + (ClassDecl context cname tyvars fds sigs _ names src_loc) -- Everything else is here + = -- The newLocals call is tiresome: given a generic class decl -- class C a where -- op :: a -> a -- op {| x+y |} (Inl a) = ... @@ -360,68 +403,17 @@ rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. -- Hence the + extendTyVarEnvFVRn (map hsTyVarName tyvars) $ getLocalNameEnv `thenRn` \ name_env -> let meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, - not (tv `elemFM` name_env)] + not (tv `elemRdrEnv` name_env)] in checkDupOrQualNames meth_doc meth_rdr_names_w_locs `thenRn_` newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> - - -- Typechecker is responsible for checking that we only - -- give default-method bindings for things in this class. - -- The renamer *could* check this for class decls, but can't - -- for instance decls. - - returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') mbinds' - names' src_loc, - sig_fvs `plusFV` - - fix_fvs `plusFV` - cxt_fvs `plusFV` - fds_fvs `plusFV` - meth_fvs - ) - ) - where - cls_doc = text "the declaration for class" <+> ppr cname - sig_doc = text "the signatures for class" <+> ppr cname - meth_doc = text "the default-methods for class" <+> ppr cname - - rn_op clas clas_tyvars clas_fds sig@(ClassOpSig op maybe_dm_stuff ty locn) - = pushSrcLocRn locn $ - lookupTopBndrRn op `thenRn` \ op_name -> - - -- Check the signature - rnHsSigType (quotes (ppr op)) ty `thenRn` \ (new_ty, op_ty_fvs) -> - let - check_in_op_ty clas_tyvar = - checkRn (clas_tyvar `elemNameSet` oclose clas_fds op_ty_fvs) - (classTyVarNotInOpTyErr clas_tyvar sig) - in - mapRn_ check_in_op_ty clas_tyvars `thenRn_` - - -- Make the default-method name - (case maybe_dm_stuff of - Nothing -> returnRn (Nothing, emptyFVs) -- Source-file class decl - - Just (DefMeth dm_rdr_name) - -> -- Imported class that has a default method decl - -- See comments with tname, snames, above - lookupSysBinder dm_rdr_name `thenRn` \ dm_name -> - returnRn (Just (DefMeth dm_name), unitFV dm_name) - -- An imported class decl for a class decl that had an explicit default - -- method, mentions, rather than defines, - -- the default method, so we must arrange to pull it in - Just GenDefMeth - -> returnRn (Just GenDefMeth, emptyFVs) - Just NoDefMeth - -> returnRn (Just NoDefMeth, emptyFVs) - ) `thenRn` \ (maybe_dm_stuff', dm_fvs) -> - - returnRn (ClassOpSig op_name maybe_dm_stuff' new_ty locn, op_ty_fvs `plusFV` dm_fvs) + returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs) \end{code} @@ -451,7 +443,7 @@ rnDerivs (Just clss) conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) conDeclName (ConDecl n _ _ _ _ l) = (n,l) -rnConDecl :: RdrNameConDecl -> RnMS (RenamedConDecl, FreeVars) +rnConDecl :: RdrNameConDecl -> RnMS RenamedConDecl rnConDecl (ConDecl name wkr tvs cxt details locn) = pushSrcLocRn locn $ checkConName name `thenRn_` @@ -460,46 +452,45 @@ rnConDecl (ConDecl name wkr tvs cxt details locn) lookupSysBinder wkr `thenRn` \ new_wkr -> -- See comments with ClassDecl - bindTyVarsFVRn doc tvs $ \ new_tyvars -> - rnContext doc cxt `thenRn` \ (new_context, cxt_fvs) -> - rnConDetails doc locn details `thenRn` \ (new_details, det_fvs) -> - returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn, - cxt_fvs `plusFV` det_fvs) + bindTyVarsRn doc tvs $ \ new_tyvars -> + rnContext doc cxt `thenRn` \ new_context -> + rnConDetails doc locn details `thenRn` \ new_details -> + returnRn (ConDecl new_name new_wkr new_tyvars new_context new_details locn) where doc = text "the definition of data constructor" <+> quotes (ppr name) rnConDetails doc locn (VanillaCon tys) - = mapFvRn (rnBangTy doc) tys `thenRn` \ (new_tys, fvs) -> - returnRn (VanillaCon new_tys, fvs) + = mapRn (rnBangTy doc) tys `thenRn` \ new_tys -> + returnRn (VanillaCon new_tys) rnConDetails doc locn (InfixCon ty1 ty2) - = rnBangTy doc ty1 `thenRn` \ (new_ty1, fvs1) -> - rnBangTy doc ty2 `thenRn` \ (new_ty2, fvs2) -> - returnRn (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) + = rnBangTy doc ty1 `thenRn` \ new_ty1 -> + rnBangTy doc ty2 `thenRn` \ new_ty2 -> + returnRn (InfixCon new_ty1 new_ty2) rnConDetails doc locn (RecCon fields) = checkDupOrQualNames doc field_names `thenRn_` - mapFvRn (rnField doc) fields `thenRn` \ (new_fields, fvs) -> - returnRn (RecCon new_fields, fvs) + mapRn (rnField doc) fields `thenRn` \ new_fields -> + returnRn (RecCon new_fields) where field_names = [(fld, locn) | (flds, _) <- fields, fld <- flds] rnField doc (names, ty) = mapRn lookupTopBndrRn names `thenRn` \ new_names -> - rnBangTy doc ty `thenRn` \ (new_ty, fvs) -> - returnRn ((new_names, new_ty), fvs) + rnBangTy doc ty `thenRn` \ new_ty -> + returnRn (new_names, new_ty) rnBangTy doc (Banged ty) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> - returnRn (Banged new_ty, fvs) + = rnHsType doc ty `thenRn` \ new_ty -> + returnRn (Banged new_ty) rnBangTy doc (Unbanged ty) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> - returnRn (Unbanged new_ty, fvs) + = rnHsType doc ty `thenRn` \ new_ty -> + returnRn (Unbanged new_ty) rnBangTy doc (Unpacked ty) - = rnHsType doc ty `thenRn` \ (new_ty, fvs) -> - returnRn (Unpacked new_ty, fvs) + = rnHsType doc ty `thenRn` \ new_ty -> + returnRn (Unpacked new_ty) -- This data decl will parse OK -- data T = a Int @@ -524,14 +515,24 @@ checkConName name %********************************************************* \begin{code} -rnHsSigType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsTypeFVs doc_str ty + = rnHsType doc_str ty `thenRn` \ ty' -> + returnRn (ty', extractHsTyNames ty') + +rnHsSigTypeFVs :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsSigTypeFVs doc_str ty + = rnHsSigType doc_str ty `thenRn` \ ty' -> + returnRn (ty', extractHsTyNames ty') + +rnHsSigType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty = rnHsType (text "the type signature for" <+> doc_str) ty --------------------------------------- -rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars) +rnHsType :: SDoc -> RdrNameHsType -> RnMS RenamedHsType rnHsType doc (HsForAllTy Nothing ctxt ty) -- Implicit quantifiction in source code (no kinds on tyvars) @@ -542,7 +543,7 @@ rnHsType doc (HsForAllTy Nothing ctxt ty) mentioned_in_tau = extractHsTyRdrTyVars ty mentioned_in_ctxt = extractHsCtxtRdrTyVars ctxt mentioned = nub (mentioned_in_tau ++ mentioned_in_ctxt) - forall_tyvars = filter (not . (`elemFM` name_env)) mentioned + forall_tyvars = filter (not . (`elemRdrEnv` name_env)) mentioned in rnForAll doc (map UserTyVar forall_tyvars) ctxt ty @@ -564,71 +565,69 @@ rnHsType doc (HsForAllTy (Just forall_tyvars) ctxt tau) rnHsType doc (HsTyVar tyvar) = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (HsTyVar tyvar', unitFV tyvar') + returnRn (HsTyVar tyvar') rnHsType doc (HsOpTy ty1 opname ty2) = lookupOccRn opname `thenRn` \ name' -> - rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> - rnHsType doc ty2 `thenRn` \ (ty2',fvs2) -> - returnRn (HsOpTy ty1' name' ty2', fvs1 `plusFV` fvs2 `addOneFV` name') + rnHsType doc ty1 `thenRn` \ ty1' -> + rnHsType doc ty2 `thenRn` \ ty2' -> + returnRn (HsOpTy ty1' name' ty2') rnHsType doc (HsNumTy i) - | i == 1 = returnRn (HsNumTy i, emptyFVs) - | otherwise = failWithRn (HsNumTy i, emptyFVs) + | i == 1 = returnRn (HsNumTy i) + | otherwise = failWithRn (HsNumTy i) (ptext SLIT("Only unit numeric type pattern is valid")) rnHsType doc (HsFunTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> + = rnHsType doc ty1 `thenRn` \ ty1' -> -- Might find a for-all as the arg of a function type - rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> + rnHsType doc ty2 `thenRn` \ ty2' -> -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a - returnRn (HsFunTy ty1' ty2', fvs1 `plusFV` fvs2) + returnRn (HsFunTy ty1' ty2') rnHsType doc (HsListTy ty) - = rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (HsListTy ty', fvs `addOneFV` listTyCon_name) + = rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsListTy ty') -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsType doc (HsTupleTy (HsTupCon _ boxity) tys) -- Don't do lookupOccRn, because this is built-in syntax -- so it doesn't need to be in scope - = mapFvRn (rnHsType doc) tys `thenRn` \ (tys', fvs) -> - returnRn (HsTupleTy (HsTupCon n' boxity) tys', fvs `addOneFV` n') + = mapFvRn (rnHsType doc) tys `thenRn` \ tys' -> + returnRn (HsTupleTy (HsTupCon n' boxity) tys') where n' = tupleTyCon_name boxity (length tys) rnHsType doc (HsAppTy ty1 ty2) - = rnHsType doc ty1 `thenRn` \ (ty1', fvs1) -> - rnHsType doc ty2 `thenRn` \ (ty2', fvs2) -> - returnRn (HsAppTy ty1' ty2', fvs1 `plusFV` fvs2) + = rnHsType doc ty1 `thenRn` \ ty1' -> + rnHsType doc ty2 `thenRn` \ ty2' -> + returnRn (HsAppTy ty1' ty2') rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenRn` \ (pred', fvs) -> - returnRn (HsPredTy pred', fvs) + = rnPred doc pred `thenRn` \ pred' -> + returnRn (HsPredTy pred') rnHsType doc (HsUsgForAllTy uv_rdr ty) = bindUVarRn doc uv_rdr $ \ uv_name -> - rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (HsUsgForAllTy uv_name ty', - fvs ) + rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsUsgForAllTy uv_name ty') rnHsType doc (HsUsgTy usg ty) - = newUsg usg `thenRn` \ (usg', usg_fvs) -> - rnHsType doc ty `thenRn` \ (ty', ty_fvs) -> + = newUsg usg `thenRn` \ usg' -> + rnHsType doc ty `thenRn` \ ty' -> -- A for-all can occur inside a usage annotation - returnRn (HsUsgTy usg' ty', - usg_fvs `plusFV` ty_fvs) + returnRn (HsUsgTy usg' ty') where newUsg usg = case usg of - HsUsOnce -> returnRn (HsUsOnce, emptyFVs) - HsUsMany -> returnRn (HsUsMany, emptyFVs) + HsUsOnce -> returnRn HsUsOnce + HsUsMany -> returnRn HsUsMany HsUsVar uv_rdr -> lookupOccRn uv_rdr `thenRn` \ uv_name -> - returnRn (HsUsVar uv_name, emptyFVs) + returnRn (HsUsVar uv_name) -rnHsTypes doc tys = mapFvRn (rnHsType doc) tys +rnHsTypes doc tys = mapRn (rnHsType doc) tys \end{code} \begin{code} @@ -636,28 +635,27 @@ rnHsTypes doc tys = mapFvRn (rnHsType doc) tys -- and we need the workers... rnHsTupCon (HsTupCon n boxity) = lookupOccRn n `thenRn` \ n' -> - returnRn (HsTupCon n' boxity, unitFV n') + returnRn (HsTupCon n' boxity) rnHsTupConWkr (HsTupCon n boxity) -- Tuple construtors are for the *worker* of the tuple -- Going direct saves needless messing about = lookupOccRn (mkRdrNameWkr n) `thenRn` \ n' -> - returnRn (HsTupCon n' boxity, unitFV n') + returnRn (HsTupCon n' boxity) \end{code} \begin{code} rnForAll doc forall_tyvars ctxt ty = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars -> - rnContext doc ctxt `thenRn` \ (new_ctxt, cxt_fvs) -> - rnHsType doc ty `thenRn` \ (new_ty, ty_fvs) -> - returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty, - cxt_fvs `plusFV` ty_fvs) + rnContext doc ctxt `thenRn` \ new_ctxt -> + rnHsType doc ty `thenRn` \ new_ty -> + returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) \end{code} \begin{code} -rnContext :: SDoc -> RdrNameContext -> RnMS (RenamedContext, FreeVars) +rnContext :: SDoc -> RdrNameContext -> RnMS RenamedContext rnContext doc ctxt - = mapAndUnzipRn rn_pred ctxt `thenRn` \ (theta, fvs_s) -> + = mapRn rn_pred ctxt `thenRn` \ theta -> let (_, dups) = removeDupsEq theta -- We only have equality, not ordering @@ -665,17 +663,17 @@ rnContext doc ctxt -- Check for duplicate assertions -- If this isn't an error, then it ought to be: mapRn (addWarnRn . dupClassAssertWarn theta) dups `thenRn_` - returnRn (theta, plusFVs fvs_s) + returnRn theta where --Someone discovered that @CCallable@ and @CReturnable@ -- could be used in contexts such as: -- foo :: CCallable a => a -> PrimIO Int -- Doing this utterly wrecks the whole point of introducing these -- classes so we specifically check that this isn't being done. - rn_pred pred = rnPred doc pred `thenRn` \ (pred', fvs)-> + rn_pred pred = rnPred doc pred `thenRn` \ pred'-> checkRn (not (bad_pred pred')) (naughtyCCallContextErr pred') `thenRn_` - returnRn (pred', fvs) + returnRn pred' bad_pred (HsPClass clas _) = getUnique clas `elem` cCallishClassKeys bad_pred other = False @@ -683,13 +681,13 @@ rnContext doc ctxt rnPred doc (HsPClass clas tys) = lookupOccRn clas `thenRn` \ clas_name -> - rnHsTypes doc tys `thenRn` \ (tys', fvs) -> - returnRn (HsPClass clas_name tys', fvs `addOneFV` clas_name) + rnHsTypes doc tys `thenRn` \ tys' -> + returnRn (HsPClass clas_name tys') rnPred doc (HsPIParam n ty) = newIPName n `thenRn` \ name -> - rnHsType doc ty `thenRn` \ (ty', fvs) -> - returnRn (HsPIParam name ty', fvs) + rnHsType doc ty `thenRn` \ ty' -> + returnRn (HsPIParam name ty') \end{code} \begin{code} @@ -717,90 +715,84 @@ rnHsTyvar doc tyvar %********************************************************* \begin{code} -rnIdInfo (HsStrictness str) = returnRn (HsStrictness str, emptyFVs) - rnIdInfo (HsWorker worker) = lookupOccRn worker `thenRn` \ worker' -> - returnRn (HsWorker worker', unitFV worker') - -rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ (expr', fvs) -> - returnRn (HsUnfold inline expr', fvs) -rnIdInfo (HsArity arity) = returnRn (HsArity arity, emptyFVs) -rnIdInfo HsNoCafRefs = returnRn (HsNoCafRefs, emptyFVs) -rnIdInfo HsCprInfo = returnRn (HsCprInfo, emptyFVs) - + returnRn (HsWorker worker') + +rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' -> + returnRn (HsUnfold inline expr') +rnIdInfo (HsStrictness str) = returnRn (HsStrictness str) +rnIdInfo (HsArity arity) = returnRn (HsArity arity) +rnIdInfo HsNoCafRefs = returnRn HsNoCafRefs +rnIdInfo HsCprInfo = returnRn HsCprInfo \end{code} @UfCore@ expressions. \begin{code} rnCoreExpr (UfType ty) - = rnHsType (text "unfolding type") ty `thenRn` \ (ty', fvs) -> - returnRn (UfType ty', fvs) + = rnHsType (text "unfolding type") ty `thenRn` \ ty' -> + returnRn (UfType ty') rnCoreExpr (UfVar v) = lookupOccRn v `thenRn` \ v' -> - returnRn (UfVar v', unitFV v') + returnRn (UfVar v') rnCoreExpr (UfLit l) - = returnRn (UfLit l, emptyFVs) + = returnRn (UfLit l) rnCoreExpr (UfLitLit l ty) - = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> - returnRn (UfLitLit l ty', fvs) + = rnHsType (text "litlit") ty `thenRn` \ ty' -> + returnRn (UfLitLit l ty') rnCoreExpr (UfCCall cc ty) - = rnHsType (text "ccall") ty `thenRn` \ (ty', fvs) -> - returnRn (UfCCall cc ty', fvs) + = rnHsType (text "ccall") ty `thenRn` \ ty' -> + returnRn (UfCCall cc ty') rnCoreExpr (UfTuple con args) - = rnHsTupConWkr con `thenRn` \ (con', fvs1) -> - mapFvRn rnCoreExpr args `thenRn` \ (args', fvs2) -> - returnRn (UfTuple con' args', fvs1 `plusFV` fvs2) + = rnHsTupConWkr con `thenRn` \ con' -> + mapRn rnCoreExpr args `thenRn` \ args' -> + returnRn (UfTuple con' args') rnCoreExpr (UfApp fun arg) - = rnCoreExpr fun `thenRn` \ (fun', fv1) -> - rnCoreExpr arg `thenRn` \ (arg', fv2) -> - returnRn (UfApp fun' arg', fv1 `plusFV` fv2) + = rnCoreExpr fun `thenRn` \ fun' -> + rnCoreExpr arg `thenRn` \ arg' -> + returnRn (UfApp fun' arg') rnCoreExpr (UfCase scrut bndr alts) - = rnCoreExpr scrut `thenRn` \ (scrut', fvs1) -> - bindCoreLocalFVRn bndr ( \ bndr' -> - mapFvRn rnCoreAlt alts `thenRn` \ (alts', fvs2) -> - returnRn (UfCase scrut' bndr' alts', fvs2) - ) `thenRn` \ (case', fvs3) -> - returnRn (case', fvs1 `plusFV` fvs3) + = rnCoreExpr scrut `thenRn` \ scrut' -> + bindCoreLocalFVRn bndr $ \ bndr' -> + mapRn rnCoreAlt alts `thenRn` \ alts' -> + returnRn (UfCase scrut' bndr' alts') rnCoreExpr (UfNote note expr) - = rnNote note `thenRn` \ (note', fvs1) -> - rnCoreExpr expr `thenRn` \ (expr', fvs2) -> - returnRn (UfNote note' expr', fvs1 `plusFV` fvs2) + = rnNote note `thenRn` \ note' -> + rnCoreExpr expr `thenRn` \ expr' -> + returnRn (UfNote note' expr') rnCoreExpr (UfLam bndr body) = rnCoreBndr bndr $ \ bndr' -> - rnCoreExpr body `thenRn` \ (body', fvs) -> - returnRn (UfLam bndr' body', fvs) + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfLam bndr' body') rnCoreExpr (UfLet (UfNonRec bndr rhs) body) - = rnCoreExpr rhs `thenRn` \ (rhs', fvs1) -> - rnCoreBndr bndr ( \ bndr' -> - rnCoreExpr body `thenRn` \ (body', fvs2) -> - returnRn (UfLet (UfNonRec bndr' rhs') body', fvs2) - ) `thenRn` \ (result, fvs3) -> - returnRn (result, fvs1 `plusFV` fvs3) + = rnCoreExpr rhs `thenRn` \ rhs' -> + rnCoreBndr bndr $ \ bndr' -> + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfLet (UfNonRec bndr' rhs') body') rnCoreExpr (UfLet (UfRec pairs) body) = rnCoreBndrs bndrs $ \ bndrs' -> - mapFvRn rnCoreExpr rhss `thenRn` \ (rhss', fvs1) -> - rnCoreExpr body `thenRn` \ (body', fvs2) -> - returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body', fvs1 `plusFV` fvs2) + mapRn rnCoreExpr rhss `thenRn` \ rhss' -> + rnCoreExpr body `thenRn` \ body' -> + returnRn (UfLet (UfRec (bndrs' `zip` rhss')) body') where (bndrs, rhss) = unzip pairs \end{code} \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside - = rnHsType doc ty `thenRn` \ (ty', fvs1) -> + = rnHsType doc ty `thenRn` \ ty' -> bindCoreLocalFVRn name ( \ name' -> thing_inside (UfValBinder name' ty') ) `thenRn` \ (result, fvs2) -> @@ -809,7 +801,7 @@ rnCoreBndr (UfValBinder name ty) thing_inside doc = text "unfolding id" rnCoreBndr (UfTyBinder name kind) thing_inside - = bindCoreLocalFVRn name $ \ name' -> + = bindCoreLocalRn name $ \ name' -> thing_inside (UfTyBinder name' kind) rnCoreBndrs [] thing_inside = thing_inside [] @@ -820,40 +812,38 @@ rnCoreBndrs (b:bs) thing_inside = rnCoreBndr b $ \ name' -> \begin{code} rnCoreAlt (con, bndrs, rhs) - = rnUfCon con bndrs `thenRn` \ (con', fvs1) -> - bindCoreLocalsFVRn bndrs ( \ bndrs' -> - rnCoreExpr rhs `thenRn` \ (rhs', fvs2) -> - returnRn ((con', bndrs', rhs'), fvs2) - ) `thenRn` \ (result, fvs3) -> - returnRn (result, fvs1 `plusFV` fvs3) + = rnUfCon con bndrs `thenRn` \ con' -> + bindCoreLocalsRn bndrs $ \ bndrs' -> + rnCoreExpr rhs `thenRn` \ rhs' -> + returnRn (con', bndrs', rhs') rnNote (UfCoerce ty) - = rnHsType (text "unfolding coerce") ty `thenRn` \ (ty', fvs) -> - returnRn (UfCoerce ty', fvs) + = rnHsType (text "unfolding coerce") ty `thenRn` \ ty' -> + returnRn (UfCoerce ty') -rnNote (UfSCC cc) = returnRn (UfSCC cc, emptyFVs) -rnNote UfInlineCall = returnRn (UfInlineCall, emptyFVs) -rnNote UfInlineMe = returnRn (UfInlineMe, emptyFVs) +rnNote (UfSCC cc) = returnRn (UfSCC cc) +rnNote UfInlineCall = returnRn UfInlineCall +rnNote UfInlineMe = returnRn UfInlineMe rnUfCon UfDefault _ - = returnRn (UfDefault, emptyFVs) + = returnRn UfDefault rnUfCon (UfTupleAlt tup_con) bndrs - = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _, fvs) -> - returnRn (UfDataAlt con', fvs) + = rnHsTupCon tup_con `thenRn` \ (HsTupCon con' _) -> + returnRn (UfDataAlt con') -- Makes the type checker a little easier rnUfCon (UfDataAlt con) _ = lookupOccRn con `thenRn` \ con' -> - returnRn (UfDataAlt con', unitFV con') + returnRn (UfDataAlt con') rnUfCon (UfLitAlt lit) _ - = returnRn (UfLitAlt lit, emptyFVs) + = returnRn (UfLitAlt lit) rnUfCon (UfLitLitAlt lit ty) _ - = rnHsType (text "litlit") ty `thenRn` \ (ty', fvs) -> - returnRn (UfLitLitAlt lit ty', fvs) + = rnHsType (text "litlit") ty `thenRn` \ ty' -> + returnRn (UfLitLitAlt lit ty') \end{code} %********************************************************* @@ -886,12 +876,6 @@ validRuleLhs foralls lhs derivingNonStdClassErr clas = hsep [ptext SLIT("non-standard class"), ppr clas, ptext SLIT("in deriving clause")] -classTyVarNotInOpTyErr clas_tyvar sig - = hang (hsep [ptext SLIT("Class type variable"), - quotes (ppr clas_tyvar), - ptext SLIT("does not appear in method signature")]) - 4 (ppr sig) - badDataCon name = hsep [ptext SLIT("Illegal data constructor name"), quotes (ppr name)] diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index d6e7146..c3dd6e4 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -258,7 +258,7 @@ simplifyPgm :: DynFlags -> [CoreBind] -- Input -> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings -simplifyPgm dflags (imported_rule_ids, rule_lhs_fvs) +simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs) sw_chkr us binds = do { beginPass dflags "Simplify"; diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index ab1436b..172bfde 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -389,7 +389,7 @@ mkVarArg v | isId v = Var v %************************************************************************ \begin{code} -addRule :: Id -> CoreRules -> CoreRule -> CoreRules +addRule :: CoreRules -> Id -> CoreRule -> CoreRules -- Insert the new rule just before a rule that is *less specific* -- than the new one; or at the end if there isn't such a one. @@ -399,11 +399,11 @@ addRule :: Id -> CoreRules -> CoreRule -> CoreRules -- We make no check for rules that unify without one dominating -- the other. Arguably this would be a bug. -addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _) +addRule (Rules rules rhs_fvs) id rule@(BuiltinRule _) = Rules (rule:rules) rhs_fvs -- Put it at the start for lack of anything better -addRule id (Rules rules rhs_fvs) rule +addRule (Rules rules rhs_fvs) id rule = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) where new_rule = occurAnalyseRule rule @@ -433,7 +433,7 @@ addIdSpecialisations id spec_stuff where rule_name = _PK_ ("SPEC " ++ showSDoc (ppr id)) new_rules = foldr add (idSpecialisation id) spec_stuff - add (vars, args, rhs) rules = addRule id rules (Rule rule_name vars args rhs) + add (vars, args, rhs) rules = addRule rules id (Rule rule_name vars args rhs) \end{code} @@ -477,41 +477,49 @@ orphanRule (ProtoCoreRule local fn _) %************************************************************************ \begin{code} -data RuleBase = RuleBase (IdEnv CoreRules) -- Maps an Id to its rules - IdSet -- Ids (whether local or imported) mentioned on - -- LHS of some rule; these should be black listed +data RuleBase = RuleBase + IdSet -- Ids with their rules in their specialisations + -- Held as a set, so that it can simply be the initial + -- in-scope set in the simplifier -emptyRuleBase = RuleBase emptyVarEnv emptyVarSet + IdSet -- Ids (whether local or imported) mentioned on + -- LHS of some rule; these should be black listed -extendRuleBaseList :: RuleBase -> [(Name,CoreRule)] -> RuleBase +emptyRuleBase = RuleBase emptyVarSet emptyVarSet + +extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase extendRuleBaseList rule_base new_guys - = foldr extendRuleBase rule_base new_guys + = foldl extendRuleBase rule_base new_guys -extendRuleBase :: RuleBase -> (Name,CoreRule) -> RuleBase -extendRuleBase (RuleBase rule_env rule_fvs) (id, rule) - = RuleBase (extendVarEnv rule_env id (addRule id rules_for_id rule)) +extendRuleBase :: RuleBase -> (Id,CoreRule) -> RuleBase +extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule) + = RuleBase (extendVarSet rule_ids new_id) (rule_fvs `unionVarSet` extendVarSet lhs_fvs id) where - rules_for_id = case lookupWithDefaultVarEnv rule_env emptyCoreRules id - + new_id = setIdSpecialisation id (addRule old_rules id rule) + old_rules = case lookupVarSet rule_ids id of + Nothing -> emptyCoreRules + Just id' -> idSpecialisation id' + lhs_fvs = ruleSomeLhsFreeVars isId rule -- Find *all* the free Ids of the LHS, not just -- locally defined ones!! -unionRuleBase (rule_ids1, black_ids1) (rule_ids2, black_ids2) - = (plusUFM_C merge_rules rule_ids1 rule_ids2, - unionVarSet black_ids1 black_ids2) +unionRuleBase (RuleBase rule_ids1 black_ids1) (RuleBase rule_ids2 black_ids2) + = RuleBase (plusUFM_C merge_rules rule_ids1 rule_ids2) + (unionVarSet black_ids1 black_ids2) where - merge_rules id1 id2 = let rules1 = idSpecialisation id1 - rules2 = idSpecialisation id2 - new_rules = foldl (addRule id1) rules1 (rulesRules rules2) - in - setIdSpecialisation id1 new_rules + +merge_rules id1 id2 = let rules1 = idSpecialisation id1 + rules2 = idSpecialisation id2 + new_rules = foldl (addRule id1) rules1 (rulesRules rules2) + in + setIdSpecialisation id1 new_rules pprRuleBase :: RuleBase -> SDoc -pprRuleBase (rules,_) = vcat [ pprCoreRule (ppr id) rs - | id <- varSetElems rules, - rs <- rulesRules $ idSpecialisation id ] +pprRuleBase (RuleBase rules _) = vcat [ pprCoreRule (ppr id) rs + | id <- varSetElems rules, + rs <- rulesRules $ idSpecialisation id ] -- prepareLocalRuleBase takes the CoreBinds and rules defined in this module. -- It attaches those rules that are for local Ids to their binders, and @@ -521,11 +529,13 @@ pprRuleBase (rules,_) = vcat [ pprCoreRule (ppr id) rs -- The rule Ids and LHS Ids are black-listed; that is, they aren't inlined -- so that the opportunity to apply the rule isn't lost too soon -prepareLocalRuleBase :: [CoreBind] -> [ProtoCoreRule] -> ([CoreBind], RuleBase) +prepareLocalRuleBase :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], RuleBase) prepareLocalRuleBase binds local_rules - = (map zap_bind binds, (imported_id_rule_ids, rule_lhs_fvs)) + = error "urk" +{- + = (map zap_bind binds, RuleBase imported_id_rule_ids rule_lhs_fvs) where - (rule_ids, rule_lhs_fvs) = foldr add_rule emptyRuleBase local_rules + RuleBase rule_ids rule_lhs_fvs = extendRuleBaseList emptyRuleBase local_rules imported_id_rule_ids = filterVarSet (not . isLocallyDefined) rule_ids -- rule_fvs is the set of all variables mentioned in this module's rules @@ -553,13 +563,17 @@ prepareLocalRuleBase binds local_rules Just bndr' -> setIdNoDiscard bndr' Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr | otherwise -> bndr +-} -addRuleToId id rule = setIdSpecialisation id (addRule id (idSpecialisation id) rule) +addRuleToId id rule = setIdSpecialisation id (addRule (idSpecialisation id) id rule) -- prepareOrphanRuleBase does exactly the same as prepareLocalRuleBase, except that -- it assumes that none of the rules can be attached to local Ids. prepareOrphanRuleBase :: [ProtoCoreRule] -> RuleBase prepareOrphanRuleBase imported_rules - = foldr add_rule (emptyVarSet, emptyVarSet) imported_rules + = error "urk" +{- + = foldr add_rule emptyRuleBase imported_rules +-} \end{code} diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 782c1dc..55a805b 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -31,7 +31,7 @@ import TcEnv ( TcId, TcEnv, TyThingDetails(..), tcAddImportedIdInfo, tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName ) import TcBinds ( tcBindWithSigs, tcSpecSigs ) -import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, sigCtxt, mkTcSig ) +import TcMonoType ( tcHsSigType, tcClassContext, checkSigTyVars, checkAmbiguity, sigCtxt, mkTcSig ) import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns ) import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars ) import TcMonad @@ -113,7 +113,7 @@ tcClassDecl1 rec_env -- LOOK THINGS UP IN THE ENVIRONMENT tcLookupClass class_name `thenTc` \ clas -> let - tyvars = classTyVars clas + (tyvars, fds) = classTvsFds clas op_sigs = filter isClassOpSig class_sigs op_names = [n | ClassOpSig n _ _ _ <- op_sigs] (_, datacon_name, datacon_wkr_name, sc_sel_names) = getClassDeclSysNames sys_names @@ -128,7 +128,8 @@ tcClassDecl1 rec_env tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, - mapTc (tcClassSig rec_env clas tyvars dm_info) op_sigs `thenTc` \ sig_stuff -> + mapTc (tcClassSig rec_env tyvar_names clas tyvars fds dm_info) + op_sigs `thenTc` \ sig_stuff -> -- MAKE THE CLASS DETAILS let @@ -236,8 +237,10 @@ tcSuperClasses clas context sc_sel_names tcClassSig :: TcEnv -- Knot tying only! + -> [HsTyVarBndr Name] -- From the declaration, for error messages -> Class -- ...ditto... -> [TyVar] -- The class type variable, used for error check only + -> [FunDep TyVar] -> NameEnv (DefMeth Name) -- Info about default methods -> RenamedClassOpSig -> TcM (Type, -- Type of the method @@ -248,20 +251,17 @@ tcClassSig :: TcEnv -- Knot tying only! -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the -- Class.DefMeth data structure. -tcClassSig rec_env clas clas_tyvars dm_info +tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info (ClassOpSig op_name maybe_dm op_ty src_loc) = tcAddSrcLoc src_loc $ -- Check the type signature. NB that the envt *already has* -- bindings for the type variables; see comments in TcTyAndClassDcls. - -- NB: Renamer checks that the class type variable is mentioned in local_ty, - -- and that it is not constrained by theta tcHsSigType op_ty `thenTc` \ local_ty -> let - global_ty = mkSigmaTy clas_tyvars - [mkClassPred clas (mkTyVarTys clas_tyvars)] - local_ty + theta = [mkClassPred clas (mkTyVarTys clas_tyvars)] + global_ty = mkSigmaTy clas_tyvars theta local_ty -- Build the selector id and default method id sel_id = mkDictSelId op_name clas @@ -274,7 +274,12 @@ tcClassSig rec_env clas clas_tyvars dm_info DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id) where dm_id = mkDefaultMethodId dm_name clas global_ty + + full_hs_ty = HsForAllTy (Just tyvar_names) op_ty in + -- Check for ambiguous class op types + checkAmbiguity full_ty clas_tyvars theta local_ty `thenRn_` + -- Check that for a generic method, the type of -- the method is sufficiently simple checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty) diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 93d86c4..cc7bb71 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -5,7 +5,7 @@ \begin{code} module TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, - tcContext, tcClassContext, + tcContext, tcClassContext, checkAmbiguity, -- Kind checking kcHsTyVar, kcHsTyVars, mkTyClTyVars, @@ -374,6 +374,7 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) checkAmbiguity full_ty tyvars theta tau `thenTc_` returnTc (mkSigmaTy tyvars theta tau) +checkAmbiguity :: RenamedHsType -> [TyVar] -> ThetaType -> Type -> TcM () -- Check for ambiguity -- forall V. P => tau -- is ambiguous if P contains generic variables @@ -393,7 +394,7 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) -- This is the is_free test below. checkAmbiguity full_ty forall_tyvars theta tau - = mapTc check_pred theta + = mapTc_ check_pred theta where tau_vars = tyVarsOfType tau fds = instFunDepsOfTheta theta diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 3e3e90f..a8d6a96 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,7 +8,7 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) ) +import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), isIfaceRuleDecl ) import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl ) import HscTypes ( PackageRuleEnv ) @@ -40,10 +40,7 @@ tcRules pkg_rule_env decls plusLIEs lies, new_local_rules) where rule_decls = [rule | RuleD rule <- decls] - (imported_rules, local_rules) = partition is_iface_rule rule_decls - - is_iface_rule (IfaceRule _ _ _ _ _ _) = True - is_iface_rule other = False + (imported_rules, local_rules) = partition isIfaceRuleDecl rule_decls tcIfaceRule :: RenamedRuleDecl -> TcM (Id, CoreRule) -- No zonking necessary! diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 674dc3b..10f9eed 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -10,7 +10,7 @@ import HsSyn ( HsExpr(..), InPat(..), mkSimpleMatch ) import Type ( Type, isUnLiftedType, applyTys, tyVarsOfType, tyVarsOfTypes, mkTyVarTys, mkForAllTys, mkTyConApp, splitFunTys, - mkFunTy, funResultTy, isTyVarTy, splitForAllTys, + mkFunTy, isTyVarTy, splitSigmaTy, getTyVar, splitTyConApp_maybe, funTyCon ) @@ -21,12 +21,12 @@ import TyCon ( TyCon, tyConTyVars, tyConDataConsIfAvailable, ) import Name ( Name, mkSysLocalName ) import CoreSyn ( mkLams, Expr(..), CoreExpr, AltCon(..), Note(..), - mkConApp, Alt, Bind (..), mkTyApps, mkVarApps ) -import BasicTypes ( RecFlag(..), EP(..), Boxity(..) ) + mkConApp, Alt, mkTyApps, mkVarApps ) +import BasicTypes ( EP(..), Boxity(..) ) import Var ( TyVar ) import VarSet ( isEmptyVarSet ) -import Id ( Id, mkTemplateLocal, mkTemplateLocals, idType, idName, - mkTemplateLocalsNum, mkVanillaId, mkId +import Id ( Id, mkTemplateLocal, idType, idName, + mkTemplateLocalsNum, mkId ) import TysWiredIn ( genericTyCons, genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon, @@ -35,9 +35,9 @@ import TysWiredIn ( genericTyCons, import IdInfo ( vanillaIdInfo, setUnfoldingInfo ) import CoreUnfold ( mkTopUnfolding ) -import Unique ( Uniquable(..), mkBuiltinUnique ) +import Unique ( mkBuiltinUnique ) import SrcLoc ( builtinSrcLoc ) -import Maybes ( maybeToBool, expectJust ) +import Maybes ( expectJust ) import Outputable #include "HsVersions.h" -- 1.7.10.4