From 90fa6b84fdc99ba99c0b7df9691ca69d50b62530 Mon Sep 17 00:00:00 2001 From: simonpj Date: Wed, 25 Oct 2000 12:56:23 +0000 Subject: [PATCH] [project @ 2000-10-25 12:56:20 by simonpj] Tons of stuff for the mornings work --- ghc/compiler/Simon-log | 11 ++ ghc/compiler/basicTypes/Name.lhs | 4 +- ghc/compiler/coreSyn/CoreSyn.lhs | 17 +- ghc/compiler/coreSyn/CoreTidy.lhs | 27 +-- ghc/compiler/coreSyn/CoreUnfold.lhs | 2 +- ghc/compiler/coreSyn/PprCore.lhs | 5 +- ghc/compiler/deSugar/Desugar.lhs | 11 +- ghc/compiler/hsSyn/HsDecls.lhs | 54 +++--- ghc/compiler/hsSyn/HsSyn.lhs | 1 - ghc/compiler/main/HscTypes.lhs | 5 +- ghc/compiler/main/MkIface.lhs | 323 +++++++++++++++++-------------- ghc/compiler/prelude/TysWiredIn.lhs | 1 + ghc/compiler/rename/Rename.lhs | 36 ++-- ghc/compiler/rename/RnBinds.hi-boot | 2 +- ghc/compiler/rename/RnBinds.hi-boot-5 | 2 +- ghc/compiler/rename/RnBinds.lhs | 20 +- ghc/compiler/rename/RnEnv.lhs | 20 +- ghc/compiler/rename/RnHiFiles.lhs | 6 +- ghc/compiler/rename/RnHsSyn.lhs | 4 +- ghc/compiler/rename/RnIfaces.lhs | 19 +- ghc/compiler/rename/RnMonad.lhs | 2 +- ghc/compiler/rename/RnSource.hi-boot | 2 +- ghc/compiler/rename/RnSource.hi-boot-5 | 11 +- ghc/compiler/rename/RnSource.lhs | 83 ++++---- ghc/compiler/simplCore/SimplCore.lhs | 206 ++++++++++++-------- ghc/compiler/specialise/Rules.lhs | 111 ++--------- ghc/compiler/typecheck/TcClassDcl.lhs | 25 ++- ghc/compiler/typecheck/TcDeriv.lhs | 5 +- ghc/compiler/typecheck/TcEnv.lhs | 63 +++++- ghc/compiler/typecheck/TcInstDcls.lhs | 9 +- ghc/compiler/typecheck/TcModule.lhs | 13 +- ghc/compiler/typecheck/TcMonoType.lhs | 53 ++--- ghc/compiler/typecheck/TcRules.lhs | 41 ++-- ghc/compiler/typecheck/TcTyClsDecls.lhs | 108 +++-------- ghc/compiler/types/InstEnv.lhs | 58 +----- ghc/compiler/usageSP/UsageSPInf.lhs | 3 +- 36 files changed, 656 insertions(+), 707 deletions(-) diff --git a/ghc/compiler/Simon-log b/ghc/compiler/Simon-log index 8998ec6..3e1f79b 100644 --- a/ghc/compiler/Simon-log +++ b/ghc/compiler/Simon-log @@ -1,4 +1,15 @@ ------------------------------------ + GHCI hacking + ------------------------------------ + +* Don't forget to put deferred-type-decls back into RnIfaces + +* Do we want to record a package name in a .hi file? + Does pi_mod have a ModuleName or a Module? + +* Does teh finder + + ------------------------------------ Mainly PredTypes (28 Sept 00) ------------------------------------ diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 9fe8142..130dc90 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -41,7 +41,7 @@ module Name ( #include "HsVersions.h" import OccName -- All of it -import Module ( Module, moduleName, pprModule, mkVanillaModule, +import Module ( Module, moduleName, mkVanillaModule, isModuleInThisPackage ) import RdrName ( RdrName, mkRdrQual, mkRdrUnqual, rdrNameOcc, rdrNameModule ) @@ -480,7 +480,7 @@ toRdrName :: NamedThing a => a -> RdrName getSrcLoc = nameSrcLoc . getName isLocallyDefined = isLocallyDefinedName . getName -getOccString x = occNameString (getOccName x) +getOccString = occNameString . getOccName toRdrName = ifaceNameRdrName . getName \end{code} diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index 60a7db0..2c06210 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -28,7 +28,7 @@ module CoreSyn ( noUnfolding, mkOtherCon, unfoldingTemplate, maybeUnfoldingTemplate, otherCons, isValueUnfolding, isEvaldUnfolding, isCheapUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, -- Seq stuff seqRules, seqExpr, seqExprs, seqUnfolding, @@ -39,6 +39,7 @@ module CoreSyn ( -- Core rules CoreRules(..), -- Representation needed by friends CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only + IdCoreRule, RuleName, emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, isBuiltinRule @@ -47,9 +48,9 @@ module CoreSyn ( #include "HsVersions.h" import CostCentre ( CostCentre, noCostCentre ) -import Var ( Var, Id, TyVar, isTyVar, isId, idType ) -import Type ( Type, UsageAnn, mkTyVarTy, isUnLiftedType, seqType ) -import Literal ( Literal(MachStr), mkMachInt ) +import Var ( Var, Id, TyVar, isTyVar, isId ) +import Type ( Type, UsageAnn, mkTyVarTy, seqType ) +import Literal ( Literal, mkMachInt ) import DataCon ( DataCon, dataConId ) import VarSet import Outputable @@ -137,6 +138,7 @@ rulesRules (Rules rules _) = rules \begin{code} type RuleName = FAST_STRING +type IdCoreRule = (Id,CoreRule) -- Rules don't have their leading Id inside them data CoreRule = Rule RuleName @@ -257,6 +259,12 @@ hasUnfolding other = False hasSomeUnfolding :: Unfolding -> Bool hasSomeUnfolding NoUnfolding = False hasSomeUnfolding other = True + +neverUnfold :: Unfolding -> Bool +neverUnfold NoUnfolding = True +neverUnfold (OtherCon _) = True +neverUnfold (CoreUnfolding _ _ _ _ UnfoldNever) = True +neverUnfold other = False \end{code} @@ -296,7 +304,6 @@ type CoreExpr = Expr CoreBndr type CoreArg = Arg CoreBndr type CoreBind = Bind CoreBndr type CoreAlt = Alt CoreBndr -type CoreNote = Note \end{code} Binders are ``tagged'' with a \tr{t}: diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 6254817..e81a8bf 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -15,7 +15,6 @@ import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt ) import CoreSyn import CoreUnfold ( noUnfolding ) import CoreLint ( beginPass, endPass ) -import Rules ( ProtoCoreRule(..), RuleBase ) import UsageSPInf ( doUsageSPInf ) import VarEnv import VarSet @@ -66,9 +65,10 @@ Several tasks are done by @tidyCorePgm@ from the uniques for local thunks etc.] \begin{code} -tidyCorePgm :: DynFlags -> Module -> [CoreBind] -> RuleBase - -> IO ([CoreBind], [ProtoCoreRule]) -tidyCorePgm dflags module_name binds_in rulebase_in +tidyCorePgm :: DynFlags -> Module + -> [CoreBind] -> [IdCoreRule] + -> IO ([CoreBind], [IdCoreRule]) +tidyCorePgm dflags module_name binds_in orphans_in = do us <- mkSplitUniqSupply 'u' @@ -81,13 +81,13 @@ tidyCorePgm dflags module_name binds_in rulebase_in let (tidy_env1, binds_out) = mapAccumL (tidyBind (Just module_name)) init_tidy_env binds_in1 - rules_out = tidyProtoRules tidy_env1 (mk_local_protos rulebase_in) + orphans_out = tidyIdRules tidy_env1 orphans_in endPass dflags "Tidy Core" (dopt Opt_D_dump_simpl dflags || dopt Opt_D_verbose_core2core dflags) binds_out - return (binds_out, rules_out) + return (binds_out, orphans_out) where -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl @@ -101,11 +101,6 @@ tidyCorePgm dflags module_name binds_in rulebase_in avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, exportWithOrigOccName bndr] - mk_local_protos :: RuleBase -> [ProtoCoreRule] - mk_local_protos (rule_ids, _) - = [ProtoCoreRule True id rule | id <- varSetElems rule_ids, - rule <- rulesRules (idSpecialisation id)] - tidyBind :: Maybe Module -- (Just m) for top level, Nothing for nested -> TidyEnv -> CoreBind @@ -245,17 +240,15 @@ tidyIdInfo env info | otherwise = info `setSpecInfo` tidyRules env rules info3 = info2 `setUnfoldingInfo` noUnfolding - info4 = info3 `setDemandInfo` wwLazy -- I don't understand why... + info4 = info3 `setDemandInfo` wwLazy info5 = case workerInfo info of NoWorker -> info4 HasWorker w a -> info4 `setWorkerInfo` HasWorker (tidyVarOcc env w) a -tidyProtoRules :: TidyEnv -> [ProtoCoreRule] -> [ProtoCoreRule] -tidyProtoRules env rules - = [ ProtoCoreRule is_local (tidyVarOcc env fn) (tidyRule env rule) - | ProtoCoreRule is_local fn rule <- rules - ] +tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] +tidyIdRules env rules + = [ (tidyVarOcc env fn, tidyRule env rule) | (fn,rule) <- rules ] tidyRules :: TidyEnv -> CoreRules -> CoreRules tidyRules env (Rules rules fvs) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index ac41b7b..25659da 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -20,7 +20,7 @@ module CoreUnfold ( mkOtherCon, otherCons, unfoldingTemplate, maybeUnfoldingTemplate, isEvaldUnfolding, isValueUnfolding, isCheapUnfolding, isCompulsoryUnfolding, - hasUnfolding, hasSomeUnfolding, + hasUnfolding, hasSomeUnfolding, neverUnfold, couldBeSmallEnoughToInline, certainlyWillInline, diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 184d95f..bed901b 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -12,7 +12,7 @@ module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprIdBndr, pprCoreBinding, pprCoreBindings, - pprCoreRules, pprCoreRule + pprCoreRules, pprCoreRule, pprIdCoreRule ) where #include "HsVersions.h" @@ -361,6 +361,9 @@ ppIdInfo b info pprCoreRules :: Id -> CoreRules -> SDoc pprCoreRules var (Rules rules _) = vcat (map (pprCoreRule (ppr var)) rules) +pprIdCoreRule :: IdCoreRule -> SDoc +pprIdCoreRule (id,rule) = pprCoreRule (ppr id) rule + pprCoreRule :: SDoc -> CoreRule -> SDoc pprCoreRule pp_fn (BuiltinRule _) = ifPprDebug (ptext SLIT("A built in rule")) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 1d95438..d486059 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -14,7 +14,7 @@ import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), import TcHsSyn ( TypecheckedRuleDecl ) import TcModule ( TcResults(..) ) import CoreSyn -import Rules ( ProtoCoreRule(..), pprProtoCoreRule ) +import PprCore ( pprIdCoreRule ) import Subst ( substExpr, mkSubst, mkInScopeSet ) import DsMonad import DsExpr ( dsExpr ) @@ -48,7 +48,7 @@ deSugar :: DynFlags -> UniqSupply -> HomeSymbolTable -> TcResults - -> IO ([CoreBind], RuleEnv, SDoc, SDoc, [CoreBndr]) + -> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr]) deSugar dflags mod_name us hst (TcResults {tc_env = global_val_env, @@ -98,7 +98,7 @@ dsProgram mod_name all_binds rules fo_decls ppr_ds_rules [] = empty ppr_ds_rules rules = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ - vcat (map pprProtoCoreRule rules) + vcat (map pprIdCoreRule rules) \end{code} @@ -109,13 +109,12 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: IdSet -> TypecheckedRuleDecl -> DsM ProtoCoreRule +dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule) dsRule in_scope (HsRule name sig_tvs vars lhs rhs loc) = putSrcLocDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> dsExpr rhs `thenDs` \ core_rhs -> - returnDs (ProtoCoreRule True {- local -} fn - (Rule name tpl_vars args core_rhs)) + returnDs (fn, Rule name tpl_vars args core_rhs) where tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars] all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 26fd7bb..be61da2 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -15,7 +15,7 @@ module HsDecls ( BangType(..), getBangType, DeprecDecl(..), DeprecTxt, hsDeclName, instDeclName, tyClDeclName, tyClDeclNames, - isClassDecl, isSynDecl, isDataDecl, countTyClDecls, toHsRule, + isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls, mkClassDeclSysNames, isIfaceRuleDecl, getClassDeclSysNames ) where @@ -27,20 +27,19 @@ import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig(..) ) import HsExpr ( HsExpr ) import HsTypes import PprCore ( pprCoreRule ) -import HsCore ( UfExpr(UfVar), UfBinder, HsIdInfo, pprHsIdInfo, - eq_ufBinders, eq_ufExpr, pprUfExpr, toUfExpr, toUfBndr +import HsCore ( UfExpr, UfBinder, HsIdInfo, pprHsIdInfo, + eq_ufBinders, eq_ufExpr, pprUfExpr ) import CoreSyn ( CoreRule(..) ) import BasicTypes ( NewOrData(..) ) import CallConv ( CallConv, pprCallConv ) -import Name ( getName ) -- others: import FunDeps ( pprFundeps ) import Class ( FunDep ) import CStrings ( CLabelString, pprCLabelString ) import Outputable -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc ) \end{code} @@ -200,7 +199,29 @@ data TyClDecl name pat (MonoBinds name pat) -- default methods (ClassDeclSysNames name) SrcLoc +\end{code} + +Simple classifiers + +\begin{code} +isIfaceSigDecl, isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool + +isIfaceSigDecl (IfaceSig _ _ _ _) = True +isIfaceSigDecl other = False + +isSynDecl (TySynonym _ _ _ _) = True +isSynDecl other = False + +isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True +isDataDecl other = False + +isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True +isClassDecl other = False +\end{code} + +Dealing with names +\begin{code} tyClDeclName :: TyClDecl name pat -> name tyClDeclName (IfaceSig name _ _ _) = name tyClDeclName (TyData _ _ name _ _ _ _ _ _ _) = name @@ -238,19 +259,6 @@ getClassDeclSysNames (a:b:c:ds) = (a,b,c,ds) \end{code} \begin{code} -isDataDecl, isSynDecl, isClassDecl :: TyClDecl name pat -> Bool - -isSynDecl (TySynonym _ _ _ _) = True -isSynDecl other = False - -isDataDecl (TyData _ _ _ _ _ _ _ _ _ _) = True -isDataDecl other = False - -isClassDecl (ClassDecl _ _ _ _ _ _ _ _ ) = True -isClassDecl other = False -\end{code} - -\begin{code} instance Ord name => Eq (TyClDecl name pat) where -- Used only when building interface files (==) (IfaceSig n1 t1 i1 _) @@ -669,16 +677,6 @@ instance (Outputable name, Outputable pat) instance Outputable name => Outputable (RuleBndr name) where ppr (RuleBndr name) = ppr name ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty - -toHsRule id (BuiltinRule _) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) - -toHsRule id (Rule name bndrs args rhs) - = IfaceRule name (map toUfBndr bndrs) (getName id) - (map toUfExpr args) (toUfExpr rhs) noSrcLoc - -bogusIfaceRule id - = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc \end{code} diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index 952c07f..a23a7ac 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -38,7 +38,6 @@ import HsLit import HsMatches import HsPat import HsTypes -import HsCore import BasicTypes ( Fixity, Version, NewOrData ) -- others: diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 99b07b8..65669d8 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -54,7 +54,6 @@ import Module ( Module, ModuleName, ModuleEnv, ) import Rules ( RuleBase ) import VarSet ( TyVarSet ) -import VarEnv ( emptyVarEnv ) import Id ( Id ) import Class ( Class ) import TyCon ( TyCon ) @@ -65,7 +64,7 @@ import HsSyn ( DeprecTxt ) import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl ) import RnHsSyn ( RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl ) -import CoreSyn ( CoreRule ) +import CoreSyn ( CoreRule, IdCoreRule ) import Type ( Type ) import FiniteMap ( FiniteMap, emptyFM, addToFM, lookupFM, foldFM ) @@ -150,7 +149,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 :: [(Id,CoreRule)] -- Domain may include Ids from other modules + md_rules :: [IdCoreRule] -- Domain may include Ids from other modules } \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 601cf98..7b1123c 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -36,7 +36,7 @@ import IdInfo ( IdInfo, StrictnessInfo(..), ArityInfo(..), ) import CoreSyn ( CoreExpr, CoreBind, Bind(..), isBuiltinRule, rulesRules, rulesRhsFreeVars ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) -import CoreUnfold ( okToUnfoldInHiFile, couldBeSmallEnoughToInline ) +import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold ) import Name ( isLocallyDefined, getName, nameModule, Name, NamedThing(..), plusNameEnv, lookupNameEnv, emptyNameEnv, extendNameEnv, lookupNameEnv_NF, nameEnvElts @@ -70,8 +70,24 @@ import List ( partition ) completeModDetails :: ModDetails -> [CoreBind] -> [Id] -- Final bindings, plus the top-level Ids from the -- code generator; they have authoritative arity info - -> [ProtoCoreRule] -- Tidy orphan rules + -> [IdCoreRule] -- Tidy orphan rules -> ModDetails +completeModDetails mds tidy_binds stg_ids orphan_rules + = ModDetails { + + where + dfun_ids = md_insts mds + + final_ids = bindsToIds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids) + (mkVarSet stg_ids) + tidy_binds + + rule_dcls | opt_OmitInterfacePragmas = [] + | otherwise = getRules orphan_rules tidy_binds (mkVarSet final_ids) + + orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule + | (_, rule) <- tidy_orphan_rules] + completeIface :: Maybe ModIface -- The old interface, if we have it -> ModIface -- The new one, minus the decls and versions @@ -87,33 +103,18 @@ completeIface :: Maybe ModIface -- The old interface, if we have it -- The IO in the type is solely for debug output -- In particular, dumping a record of what has changed completeIface maybe_old_iface new_iface mod_details - tidy_binds final_ids tidy_orphan_rules - = let - new_decls = declsFromDetails mod_details tidy_binds final_ids tidy_orphan_rules - in - addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls }) - -declsFromDetails :: ModDetails -> [CoreBind] -> [Id] -> [ProtoCoreRule] -> IfaceDecls -declsFromDetails details tidy_binds final_ids tidy_orphan_rules - = IfaceDecls { dcl_tycl = ty_cls_dcls ++ bagToList val_dcls, - dcl_insts = inst_dcls, - dcl_rules = rule_dcls } - where - dfun_ids = md_insts details - inst_dcls = map ifaceInstance dfun_ids - ty_cls_dcls = map ifaceTyCls (filter emitTyCls (nameEnvElts (md_types details))) - - (val_dcls, emitted_ids) = ifaceBinds (mkVarSet dfun_ids `unionVarSet` orphan_rule_ids) - final_ids tidy_binds - - rule_dcls | opt_OmitInterfacePragmas = [] - | otherwise = ifaceRules tidy_orphan_rules emitted_ids - - orphan_rule_ids = unionVarSets [ ruleSomeFreeVars interestingId rule - | ProtoCoreRule _ _ rule <- tidy_orphan_rules] + = addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls }) + where + new_decls = IfaceDecls { dcl_tycl = ty_cls_dcls, + dcl_insts = inst_dcls, + dcl_rules = rule_dcls } + inst_dcls = map ifaceInstance (mk_insts mds) + ty_cls_dcls = map ifaceTyCls (nameEnvElts (md_types details)) + rule_dcls = map ifaceRule (md_rules details) \end{code} + %************************************************************************ %* * \subsection{Types and classes} @@ -121,13 +122,6 @@ declsFromDetails details tidy_binds final_ids tidy_orphan_rules %************************************************************************ \begin{code} -emitTyCls :: TyThing -> Bool -emitTyCls (ATyCon tc) = True -- Could filter out wired in ones, but it's not - -- strictly necessary, and it costs extra time -emitTyCls (AClass cl) = True -emitTyCls (AnId _) = False - - ifaceTyCls :: TyThing -> RenamedTyClDecl ifaceTyCls (AClass clas) = ClassDecl (toHsContext sc_theta) @@ -193,6 +187,49 @@ ifaceTyCls (ATyCon tycon) = ([getName field_label], mk_bang_ty strict_mark (fieldLabelType field_label)) ifaceTyCls (ATyCon tycon) = pprPanic "ifaceTyCls" (ppr tycon) + +ifaceTyCls (AnId id) + = IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc + where + id_type = idType id + id_info = idInfo id + + hs_idinfo | opt_OmitInterfacePragmas = [] + | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ + strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo + + ------------ Arity -------------- + arity_hsinfo = case arityInfo id_info of + a@(ArityExactly n) -> [HsArity a] + other -> [] + + ------------ Caf Info -------------- + caf_hsinfo = case cafInfo id_info of + NoCafRefs -> [HsNoCafRefs] + otherwise -> [] + + ------------ CPR Info -------------- + cpr_hsinfo = case cprInfo id_info of + ReturnsCPR -> [HsCprInfo] + NoCPRInfo -> [] + + ------------ Strictness -------------- + strict_hsinfo = case strictnessInfo id_info of + NoStrictnessInfo -> [] + info -> [HsStrictness info] + + + ------------ Worker -------------- + wkr_hsinfo = case workerInfo id_info of + HasWorker work_id wrap_arity -> [HsWorker (getName work_id)] + NoWorker -> [] + + ------------ Unfolding -------------- + unfold_info = unfoldInfo id_info + inine_prag = inlinePragInfo id_info + rhs = unfoldingTempate unfold_info + unfold_hsinfo | neverUnfold unfold_info = [] + | otherwise = [HsUnfold inline_prag (toUfExpr rhs)] \end{code} @@ -217,55 +254,40 @@ ifaceInstance dfun_id -- instance Foo Tibble where ... -- and this instance decl wouldn't get imported into a module -- that mentioned T but not Tibble. -\end{code} -\begin{code} -ifaceRules :: [ProtoCoreRule] -> IdSet -> [RenamedRuleDecl] -ifaceRules rules emitted - = orphan_rules ++ local_rules - where - orphan_rules = [ toHsRule fn rule | ProtoCoreRule _ fn rule <- rules ] - local_rules = [ toHsRule fn rule - | fn <- varSetElems emitted, - rule <- rulesRules (idSpecialisation fn), - not (isBuiltinRule rule), - -- We can't print builtin rules in interface files - -- Since they are built in, an importing module - -- will have access to them anyway +ifaceRule (id, BuiltinRule _) + = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule id) - -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules - -- from coming out, and to make it work properly we need to add ???? - -- (put it back in for now) - all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) - -- Spit out a rule only if all its lhs free vars are emitted - -- This is a good reason not to do it when we emit the Id itself - ] +ifaceRule (id, Rule name bndrs args rhs) + = IfaceRule name (map toUfBndr bndrs) (getName id) + (map toUfExpr args) (toUfExpr rhs) noSrcLoc + +bogusIfaceRule id + = IfaceRule SLIT("bogus") [] (getName id) [] (UfVar (getName id)) noSrcLoc \end{code} %************************************************************************ %* * -\subsection{Value bindings} +\subsection{Compute final Ids} %* * %************************************************************************ +A "final Id" has exactly the IdInfo for going into an interface file, or +exporting to another module. + \begin{code} -ifaceBinds :: IdSet -- These Ids are needed already - -> [Id] -- Ids used at code-gen time; they have better pragma info! +bindsToIds :: IdSet -- These Ids are needed already + -> IdSet -- Ids used at code-gen time; they have better pragma info! -> [CoreBind] -- In dependency order, later depend on earlier - -> (Bag RenamedIfaceSig, IdSet) -- Set of Ids actually spat out + -> [Id] -- Set of Ids actually spat out, complete with exactly the IdInfo + -- they need for exporting to another module -ifaceBinds needed_ids final_ids binds - = go needed_ids (reverse binds) emptyBag emptyVarSet +bindsToIds needed_ids codegen_ids binds + = go needed_ids (reverse binds) [] -- Reverse so that later things will -- provoke earlier ones to be emitted where - final_id_map = listToUFM [(id,id) | id <- final_ids] - get_idinfo id = case lookupUFM final_id_map id of - Just id' -> idInfo id' - Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ - idInfo id - -- The 'needed' set contains the Ids that are needed by earlier -- interface file emissions. If the Id isn't in this set, and isn't -- exported, there's no need to emit anything @@ -274,22 +296,21 @@ ifaceBinds needed_ids final_ids binds go needed [] decls emitted | not (isEmptyVarSet needed) = pprTrace "ifaceBinds: free vars:" (sep (map ppr (varSetElems needed))) - (decls, emitted) - | otherwise = (decls, emitted) + emitted + | otherwise = emitted - go needed (NonRec id rhs : binds) decls emitted + go needed (NonRec id rhs : binds) emitted | need_id needed id = if omitIfaceSigForId id then - go (needed `delVarSet` id) binds decls (emitted `extendVarSet` id) + go (needed `delVarSet` id) binds (id:emitted) else go ((needed `unionVarSet` extras) `delVarSet` id) binds - (decl `consBag` decls) - (emitted `extendVarSet` id) + (new_id:emitted) | otherwise = go needed binds decls emitted where - (decl, extras) = ifaceId get_idinfo False id rhs + (new_id, extras) = mkFinalId codegen_ids False id rhs -- Recursive groups are a bit more of a pain. We may only need one to -- start with, but it may call out the next one, and so on. So we @@ -297,72 +318,60 @@ ifaceBinds needed_ids final_ids binds -- because without -O we may only need the first one (if we don't emit -- its unfolding) go needed (Rec pairs : binds) decls emitted - = go needed' binds decls' emitted' + = go needed' binds emitted' where - (new_decls, new_emitted, extras) = go_rec needed pairs - decls' = new_decls `unionBags` decls + (new_emitted, extras) = go_rec needed pairs needed' = (needed `unionVarSet` extras) `minusVarSet` mkVarSet (map fst pairs) - emitted' = emitted `unionVarSet` new_emitted + emitted' = new_emitted ++ emitted - go_rec :: IdSet -> [(Id,CoreExpr)] -> (Bag RenamedIfaceSig, IdSet, IdSet) + go_rec :: IdSet -> [(Id,CoreExpr)] -> ([Id], IdSet) go_rec needed pairs - | null decls = (emptyBag, emptyVarSet, emptyVarSet) - | otherwise = (more_decls `unionBags` listToBag decls, - more_emitted `unionVarSet` mkVarSet (map fst needed_prs), - more_extras `unionVarSet` extras) + | null needed_prs = ([], emptyVarSet) + | otherwise = (emitted ++ more_emitted, + extras `unionVarSet` more_extras) where - (needed_prs,leftover_prs) = partition is_needed pairs - (decls, extras_s) = unzip [ifaceId get_idinfo True id rhs - | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)] - extras = unionVarSets extras_s - (more_decls, more_emitted, more_extras) = go_rec extras leftover_prs + (needed_prs,leftover_prs) = partition is_needed pairs + (emitted, extras_s) = unzip [ mkFinalId codegen_ids True id rhs + | (id,rhs) <- needed_prs, not (omitIfaceSigForId id)] + extras = unionVarSets extras_s + (more_emitted, more_extras) = go_rec extras leftover_prs + is_needed (id,_) = need_id needed id \end{code} + \begin{code} -ifaceId :: (Id -> IdInfo) -- This function "knows" the extra info added - -- by the STG passes. Sigh - -> Bool -- True <=> recursive, so don't print unfolding - -> Id - -> CoreExpr -- The Id's right hand side - -> (RenamedTyClDecl, IdSet) -- The emitted stuff, plus any *extra* needed Ids - -ifaceId get_idinfo is_rec id rhs - = (IfaceSig (getName id) (toHsType id_type) hs_idinfo noSrcLoc, new_needed_ids) +mkFinalId :: IdSet -- The Ids with arity info from the code generator + -> Bool -- True <=> recursive, so don't include unfolding + -> Id + -> CoreExpr -- The Id's right hand side + -> (Id, IdSet) -- The emitted id, plus any *extra* needed Ids + +mkFinalId codegen_ids is_rec id rhs + = (id `setIdInfo` new_idinfo, new_needed_ids) where id_type = idType id core_idinfo = idInfo id - stg_idinfo = get_idinfo id + stg_idinfo = case lookupVarSet codegen_ids id of + Just id' -> idInfo id' + Nothing -> pprTrace "ifaceBinds not found:" (ppr id) $ + idInfo id - hs_idinfo | opt_OmitInterfacePragmas = [] - | otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++ - strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo + new_idinfo | opt_OmitInterfacePragmas + = vanillaIdInfo + | otherwise + = core_idinfo `setArityInfo` stg_arity_info + `setCafInfo` cafInfo stg_idinfo + `setUnfoldingInfo` unfold_info + `setWorkerInfo` worker_info + `setSpecInfo` emptyCoreRules + -- We zap the specialisations because they are + -- passed on separately through the modules IdCoreRules ------------ Arity -------------- - arity_info = arityInfo stg_idinfo - stg_arity = arityLowerBound arity_info - arity_hsinfo = case arityInfo stg_idinfo of - a@(ArityExactly n) -> [HsArity a] - other -> [] - - ------------ Caf Info -------------- - caf_hsinfo = case cafInfo stg_idinfo of - NoCafRefs -> [HsNoCafRefs] - otherwise -> [] - - ------------ CPR Info -------------- - cpr_hsinfo = case cprInfo core_idinfo of - ReturnsCPR -> [HsCprInfo] - NoCPRInfo -> [] - - ------------ Strictness -------------- - strict_info = strictnessInfo core_idinfo - bottoming_fn = isBottomingStrictness strict_info - strict_hsinfo = case strict_info of - NoStrictnessInfo -> [] - info -> [HsStrictness info] - + stg_arity_info = arityInfo stg_idinfo + stg_arity = arityLowerBound arity_info ------------ Worker -------------- -- We only treat a function as having a worker if @@ -386,26 +395,30 @@ ifaceId get_idinfo is_rec id rhs -- top level lambdas are there" in interface files; but during the -- compilation of this module it means "how many things can I apply -- this to". - work_info = workerInfo core_idinfo - HasWorker work_id _ = work_info + worker_info = case workerInfo core_idinfo of + HasWorker work_id wrap_arity + | wrap_arity == stg_arity -> worker_info_in + | otherwise -> pprTrace "ifaceId: arity change:" (ppr id) + NoWorker + NoWorker -> NoWorker - has_worker = case work_info of - HasWorker work_id wrap_arity - | wrap_arity == stg_arity -> True - | otherwise -> pprTrace "ifaceId: arity change:" (ppr id) - False - - other -> False + has_worker = case worker_info of + HasWorker _ _ -> True + other -> False - wrkr_hsinfo | has_worker = [HsWorker (getName work_id)] - | otherwise = [] + HasWorker work_id _ = worker_info ------------ Unfolding -------------- inline_pragma = inlinePragInfo core_idinfo dont_inline = isNeverInlinePrag inline_pragma + loop_breaker = isLoopBreaker (occInfo core_idinfo) + bottoming_fn = isBottomingStrictness (strictnessInfo core_idinfo) - unfold_hsinfo | show_unfold = [HsUnfold inline_pragma (toUfExpr rhs)] - | otherwise = [] + unfolding = mkTopUnfolding rhs + rhs_is_small = neverUnfold unfolding + + unfold_info | show_unfold = unfolding + | otherwise = noUnfolding show_unfold = not has_worker && -- Not unnecessary not bottoming_fn && -- Not necessary @@ -414,13 +427,6 @@ ifaceId get_idinfo is_rec id rhs rhs_is_small && -- Small enough okToUnfoldInHiFile rhs -- No casms etc - rhs_is_small = couldBeSmallEnoughToInline opt_UF_HiFileThreshold rhs - - ------------ Specialisations -------------- - spec_info = specInfo core_idinfo - - ------------ Occ info -------------- - loop_breaker = isLoopBreaker (occInfo core_idinfo) ------------ Extra free Ids -------------- new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet @@ -428,13 +434,13 @@ ifaceId get_idinfo is_rec id rhs unfold_ids `unionVarSet` spec_ids + spec_ids = filterVarSet interestingId (rulesRhsFreeVars (specInfo core_idinfo)) + worker_ids | has_worker && interestingId work_id = unitVarSet work_id -- Conceivably, the worker might come from -- another module | otherwise = emptyVarSet - spec_ids = filterVarSet interestingId (rulesRhsFreeVars spec_info) - unfold_ids | show_unfold = find_fvs rhs | otherwise = emptyVarSet @@ -444,6 +450,33 @@ interestingId id = isId id && isLocallyDefined id && not (hasNoBinding id) \end{code} +\begin{code} +getRules :: [IdCoreRule] -- Orphan rules + -> [CoreBind] -- Bindings, with rules in the top-level Ids + -> IdSet -- Ids that are exported, so we need their rules + -> [IdCoreRule] +getRules orphan_rules binds emitted + = orphan_rules ++ local_rules + where + local_rules = [ (fn, rule) + | fn <- bindersOfBinds binds, + fn `elemVarSet` emitted, + rule <- rulesRules (idSpecialisation fn), + not (isBuiltinRule rule), + -- We can't print builtin rules in interface files + -- Since they are built in, an importing module + -- will have access to them anyway + + -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules + -- from coming out, and to make it work properly we need to add ???? + -- (put it back in for now) + all (`elemVarSet` emitted) (varSetElems (ruleSomeLhsFreeVars interestingId rule)) + -- Spit out a rule only if all its lhs free vars are emitted + -- This is a good reason not to do it when we emit the Id itself + ] +\end{code} + + %************************************************************************ %* * \subsection{Checking if the new interface is up to date diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 85b7c30..2ebd942 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -193,6 +193,7 @@ pcDataCon name tyvars context arg_tys tycon wrap_rdr = nameRdrName name wrap_occ = rdrNameOcc wrap_rdr + mod = nameModule name wrap_id = mkDataConWrapId data_con diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 201a631..30319e4 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -13,45 +13,42 @@ import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameDeprecation, RdrNameTyClDecl, RdrNameRuleDecl, RdrNameInstDecl ) import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDecl, - extractHsTyNames, extractHsCtxtTyNames, + extractHsTyNames, instDeclFVs, tyClDeclFVs, ruleDeclFVs ) import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) -import RnSource ( rnSourceDecls, rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl ) +import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) import RnIfaces ( slurpImpDecls, mkImportInfo, - getInterfaceExports, + getInterfaceExports, closeDecls, RecompileRequired, recompileRequired ) import RnHiFiles ( findAndReadIface, removeContext, loadExports, loadFixDecls, loadDeprecs ) import RnEnv ( availName, availsToNameSet, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, sortAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupGlobalRn, newGlobalName, - FreeVars, plusFVs, plusFV, unitFV, emptyFVs, isEmptyFVs, addOneFV + lookupOrigNames, lookupGlobalRn, newGlobalName ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, lookupModuleEnv ) import Name ( Name, isLocallyDefined, NamedThing(..), getSrcLoc, - nameOccName, nameUnique, nameModule, + nameOccName, nameModule, mkNameEnv, nameEnvElts, extendNameEnv ) import OccName ( occNameFlavour ) -import Id ( idType ) -import TyCon ( isSynTyCon, getSynTyConDefn ) import NameSet -import TysWiredIn ( unitTyCon, intTyCon, doubleTyCon, boolTyCon ) +import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, ioTyCon_RDR, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, eqString_RDR ) -import PrelInfo ( fractionalClassKeys, derivingOccurrences, wiredInThingEnv ) -import Type ( namesOfType, funTyCon ) +import PrelInfo ( derivingOccurrences ) +import Type ( funTyCon ) import ErrUtils ( dumpIfSet ) import Bag ( bagToList ) import FiniteMap ( FiniteMap, eltsFM, fmToList, emptyFM, lookupFM, @@ -62,7 +59,7 @@ import Maybes ( maybeToBool, catMaybes ) import Outputable import IO ( openFile, IOMode(..) ) import HscTypes ( Finder, PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, - ModIface(..), TyThing(..), WhatsImported(..), + ModIface(..), WhatsImported(..), VersionInfo(..), ImportVersion, IfaceDecls(..), GlobalRdrEnv, AvailEnv, Avails, GenAvailInfo(..), AvailInfo, Provenance(..), ImportReason(..), initialVersionInfo, @@ -438,21 +435,20 @@ loadHomeDecl :: (NameEnv Version, [RenamedTyClDecl]) -> (Version, RdrNameTyClDecl) -> RnMS (NameEnv Version, [RenamedTyClDecl]) loadHomeDecl (version_map, decls) (version, decl) - = rnTyClDecl decl `thenRn` \ (decl', _) -> + = rnTyClDecl decl `thenRn` \ decl' -> returnRn (extendNameEnv version_map (tyClDeclName decl') version, decl':decls) ------------------ loadHomeRules :: (Version, [RdrNameRuleDecl]) -> RnMS (Version, [RenamedRuleDecl]) loadHomeRules (version, rules) - = mapAndUnzipRn rnRuleDecl rules `thenRn` \ (rules', _) -> + = mapRn rnIfaceRuleDecl rules `thenRn` \ rules' -> returnRn (version, rules') ------------------ loadHomeInsts :: [RdrNameInstDecl] -> RnMS [RenamedInstDecl] -loadHomeInsts insts = mapAndUnzipRn rnInstDecl insts `thenRn` \ (insts', _) -> - returnRn insts' +loadHomeInsts insts = mapRn rnInstDecl insts ------------------ loadHomeUsage :: ImportVersion OccName @@ -487,7 +483,7 @@ closeIfaceDecls :: DynFlags -> Finder -> ModIface -- Get the decls from here -> IO (PersistentCompilerState, Bool, [RenamedHsDecl]) -- True <=> errors happened -closeIfaceDecls dflags finder hit hst pcs mod +closeIfaceDecls dflags finder hit hst pcs mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) = initRn dflags finder hit hst pcs mod $ @@ -499,8 +495,8 @@ closeIfaceDecls dflags finder hit hst pcs mod 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) + unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` + unionManyNameSets (map tyClDeclFVs tycl_decls) in closeDecls decls needed \end{code} @@ -706,7 +702,7 @@ rnDump imp_decls local_decls \begin{code} getRnStats :: [RenamedHsDecl] -> Ifaces -> SDoc getRnStats imported_decls ifaces - = hcat [text "Renamer stats: ", stats]) + = hcat [text "Renamer stats: ", stats] where n_mods = length [() | (_, _, True) <- eltsFM (iImpModInfo ifaces)] diff --git a/ghc/compiler/rename/RnBinds.hi-boot b/ghc/compiler/rename/RnBinds.hi-boot index 30dba74..66637e0 100644 --- a/ghc/compiler/rename/RnBinds.hi-boot +++ b/ghc/compiler/rename/RnBinds.hi-boot @@ -2,4 +2,4 @@ _interface_ RnBinds 1 _exports_ RnBinds rnBinds; _declarations_ -1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, RnEnv.FreeVars)) -> RnMonad.RnMS (b, RnEnv.FreeVars) ;; +1 rnBinds _:_ _forall_ [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ;; diff --git a/ghc/compiler/rename/RnBinds.hi-boot-5 b/ghc/compiler/rename/RnBinds.hi-boot-5 index 0bd70ba..b2fcc90 100644 --- a/ghc/compiler/rename/RnBinds.hi-boot-5 +++ b/ghc/compiler/rename/RnBinds.hi-boot-5 @@ -1,3 +1,3 @@ __interface RnBinds 1 0 where __export RnBinds rnBinds; -1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, RnEnv.FreeVars)) -> RnMonad.RnMS (b, RnEnv.FreeVars) ; +1 rnBinds :: __forall [b] => RdrHsSyn.RdrNameHsBinds -> (RnHsSyn.RenamedHsBinds -> RnMonad.RnMS (b, NameSet.FreeVars)) -> RnMonad.RnMS (b, NameSet.FreeVars) ; diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index 19d2355..7079112 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -11,7 +11,7 @@ they may be affected by renaming (which isn't fully worked out yet). \begin{code} module RnBinds ( rnTopBinds, rnTopMonoBinds, - rnMethodBinds, renameSigs, + rnMethodBinds, renameSigs, renameSigsFVs, rnBinds, unknownSigErr ) where @@ -29,7 +29,6 @@ import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch ) import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupGlobalOccRn, lookupSigOccRn, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, addOneFV ) import CmdLineOpts ( DynFlag(..) ) import Digraph ( stronglyConnComp, SCC(..) ) @@ -169,8 +168,8 @@ rnTopMonoBinds mbinds sigs let bndr_name_set = mkNameSet binder_names in - renameSigs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> - doptRn Opt_WarnMissingSigs `thenRn` \ warnMissing -> + renameSigsFVs (okBindSig bndr_name_set) sigs `thenRn` \ (siglist, sig_fvs) -> + doptRn Opt_WarnMissingSigs `thenRn` \ warnMissing -> let type_sig_vars = [n | Sig n _ _ <- siglist] un_sigd_binders | warnMissing = nameSetToList (delListFromNameSet @@ -226,7 +225,7 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds binder_set = mkNameSet new_mbinders in -- Rename the signatures - renameSigs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) -> + renameSigsFVs (okBindSig binder_set) sigs `thenRn` \ (siglist, sig_fvs) -> -- Report the fixity declarations in this group that -- don't refer to any of the group's binders. @@ -479,12 +478,15 @@ At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} +renameSigsFVs ok_sig sigs + = renameSigs ok_sig sigs `thenRn` \ sigs' -> + returnRn (sigs', hsSigsFVs sigs') + renameSigs :: (RenamedSig -> Bool) -- OK-sig predicate -> [RdrNameSig] - -> RnMS ([RenamedSig], FreeVars) + -> RnMS [RenamedSig] -renameSigs ok_sig [] - = returnRn ([], emptyFVs) -- Common shortcut +renameSigs ok_sig [] = returnRn [] renameSigs ok_sig sigs = -- Rename the signatures @@ -500,7 +502,7 @@ renameSigs ok_sig sigs (goods, bads) = partition ok_sig in_scope in mapRn_ unknownSigErr bads `thenRn_` - returnRn (goods, hsSigFVs goods) + returnRn goods -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 145c8c3..3b33542 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -351,15 +351,14 @@ bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope Just name -> pushSrcLocRn loc $ addWarnRn (shadowedNameWarn rdr_name) -bindCoreLocalFVRn :: RdrName -> (Name -> RnMS (a, FreeVars)) - -> RnMS (a, FreeVars) +bindCoreLocalRn :: RdrName -> (Name -> RnMS a) -> RnMS a -- A specialised variant when renaming stuff from interface -- files (of which there is a lot) -- * one at a time -- * no checks for shadowing -- * always imported -- * deal with free vars -bindCoreLocalFVRn rdr_name enclosed_scope +bindCoreLocalRn rdr_name enclosed_scope = getSrcLocRn `thenRn` \ loc -> getLocalNameEnv `thenRn` \ name_env -> getNameSupplyRn `thenRn` \ (us, cache, ipcache) -> @@ -372,13 +371,12 @@ bindCoreLocalFVRn rdr_name enclosed_scope let new_name_env = extendRdrEnv name_env rdr_name name in - setLocalNameEnv new_name_env (enclosed_scope name) `thenRn` \ (result, fvs) -> - returnRn (result, delFromNameSet fvs name) + setLocalNameEnv new_name_env (enclosed_scope name) -bindCoreLocalsFVRn [] thing_inside = thing_inside [] -bindCoreLocalsFVRn (b:bs) thing_inside = bindCoreLocalFVRn b $ \ name' -> - bindCoreLocalsFVRn bs $ \ names' -> - thing_inside (name':names') +bindCoreLocalsRn [] thing_inside = thing_inside [] +bindCoreLocalsRn (b:bs) thing_inside = bindCoreLocalRn b $ \ name' -> + bindCoreLocalsRn bs $ \ names' -> + thing_inside (name':names') bindLocalNames names enclosed_scope = getLocalNameEnv `thenRn` \ name_env -> @@ -408,8 +406,8 @@ bindLocalsFVRn doc rdr_names enclosed_scope returnRn (thing, delListFromNameSet fvs names) ------------------------------------- -bindUVarRn :: SDoc -> RdrName -> (Name -> RnMS (a, FreeVars)) -> RnMS (a, FreeVars) -bindUVarRn = bindLocalRn +bindUVarRn :: RdrName -> (Name -> RnMS a) -> RnMS a +bindUVarRn = bindCoreLocalRn ------------------------------------- extendTyVarEnvFVRn :: [Name] -> RnMS (a, FreeVars) -> RnMS (a, FreeVars) diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index 6bff192..4e067b9 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -27,13 +27,13 @@ import HsSyn ( HsDecl(..), TyClDecl(..), InstDecl(..), import RdrHsSyn ( RdrNameTyClDecl, RdrNameInstDecl, RdrNameRuleDecl, extractHsTyRdrNames ) -import BasicTypes ( Version ) +import BasicTypes ( Version, defaultFixity ) import RnEnv import RnMonad import ParseIface ( parseIface, IfaceStuff(..) ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, + nameModule, isLocallyDefined, NamedThing(..), mkNameEnv, extendNameEnv ) @@ -45,7 +45,7 @@ import Module ( Module, import RdrName ( RdrName, rdrNameOcc ) import NameSet import SrcLoc ( mkSrcLoc, SrcLoc ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, orElse ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 64564fc..fefcf7c 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -139,9 +139,11 @@ tyClDeclFVs (ClassDecl context _ tyvars fds sigs _ _ src_loc) = delFVs (map hsTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` plusFVs (map extractFunDepNames fds) `plusFV` - plusFVs (map hsSigFVs sigs) + hsSigsFVs sigs ---------------- +hsSigsFVs sigs = 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 diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index 8680d59..b7af688 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -10,7 +10,7 @@ module RnIfaces recordLocalSlurps, mkImportInfo, - slurpImpDecls, + slurpImpDecls, closeDecls, RecompileRequired, outOfDate, upToDate, recompileRequired ) @@ -20,18 +20,23 @@ where import CmdLineOpts ( DynFlags, opt_NoPruneDecls, opt_NoPruneTyDecls, opt_IgnoreIfacePragmas ) import HscTypes -import HsSyn ( HsDecl(..), InstDecl(..), HsType(..) ) +import HsSyn ( HsDecl(..), Sig(..), TyClDecl(..), ConDecl(..), ConDetails(..), + InstDecl(..), HsType(..), hsTyVarNames, getBangType + ) import HsImpExp ( ImportDecl(..) ) -import BasicTypes ( Version, defaultFixity ) import RdrHsSyn ( RdrNameHsDecl, RdrNameTyClDecl, RdrNameInstDecl ) +import RnHsSyn ( RenamedHsDecl, extractHsTyNames, extractHsCtxtTyNames, tyClDeclFVs ) import RnHiFiles ( tryLoadInterface, loadHomeInterface, loadInterface, loadOrphanModules ) import RnSource ( rnTyClDecl, rnDecl ) import RnEnv import RnMonad +import Id ( idType ) +import Type ( namesOfType ) +import TyCon ( isSynTyCon, getSynTyConDefn ) import Name ( Name {-instance NamedThing-}, nameOccName, - nameModule, isLocallyDefined, + nameModule, isLocallyDefined, nameUnique, NamedThing(..), elemNameEnv ) @@ -42,7 +47,8 @@ import Module ( Module, ModuleEnv, extendModuleEnv_C, lookupWithDefaultModuleEnv ) import NameSet -import PrelInfo ( wiredInThingEnv ) +import PrelInfo ( wiredInThingEnv, fractionalClassKeys ) +import TysWiredIn ( doubleTyCon ) import Maybes ( orElse ) import FiniteMap import Outputable @@ -450,7 +456,8 @@ 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) +rnIfaceTyClDecl (mod, decl) = initIfaceRnMS mod (rnTyClDecl decl) `thenRn` \ decl' -> + returnRn (decl', tyClDeclFVs decl') \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 19e22d6..ed01e18 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -54,7 +54,7 @@ import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, addListToRdrEnv, rdrEnvToList, rdrEnvElts ) import Name ( Name, OccName, NamedThing(..), getSrcLoc, - isLocallyDefinedName, nameModule, nameOccName, + isLocallyDefinedName, nameOccName, decode, mkLocalName, mkKnownKeyGlobal, NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList diff --git a/ghc/compiler/rename/RnSource.hi-boot b/ghc/compiler/rename/RnSource.hi-boot index 3d9bfa2..802d0a8 100644 --- a/ghc/compiler/rename/RnSource.hi-boot +++ b/ghc/compiler/rename/RnSource.hi-boot @@ -3,7 +3,7 @@ _exports_ RnSource rnHsType rnHsSigType rnHsTypeFVs; _declarations_ 1 rnHsTypeFVs _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType - -> RnMonad.RnMS (RnHsSyn.RenamedHsType, RnEnv.FreeVars) ;; + -> RnMonad.RnMS (RnHsSyn.RenamedHsType, NameSet.FreeVars) ;; 2 rnHsSigType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS RnHsSyn.RenamedHsType ;; 2 rnHsType _:_ Outputable.SDoc -> RdrHsSyn.RdrNameHsType diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index f2a15df..a6d6d40 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -1,8 +1,5 @@ __interface RnSource 1 0 where -__export RnSource rnHsType rnHsSigType rnHsPolyType; -1 rnHsType :: 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) ; +__export RnSource rnHsType rnHsSigType rnHsTypeFVs; +1 rnHsTypeFVs :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS (RnHsSyn.RenamedHsType, NameSet.FreeVars) ; +2 rnHsType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS RnHsSyn.RenamedHsType ; +2 rnHsSigType :: Outputable.SDoc -> RdrHsSyn.RdrNameHsType -> RnMonad.RnMS RnHsSyn.RenamedHsType ; diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index eed6188..51af082 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -4,7 +4,7 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnSource ( rnDecl, rnTyClDecl, rnRuleDecl, rnInstDecl, rnSourceDecls, +module RnSource ( rnDecl, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls, rnHsType, rnHsSigType, rnHsTypeFVs, rnHsSigTypeFVs ) where @@ -14,22 +14,21 @@ import RnExpr import HsSyn import HsTypes ( hsTyVarNames, pprHsContext ) import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv ) -import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, +import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, extractRuleBndrsTyVars, extractHsTyRdrTyVars, extractHsCtxtRdrTyVars, extractGenericPatTyVars ) import RnHsSyn import HsCore -import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs ) +import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs ) import RnEnv ( lookupTopBndrRn, lookupOccRn, newIPName, lookupOrigNames, lookupSysBinder, newLocalsRn, bindLocalsFVRn, bindUVarRn, - bindTyVarsFVRn, bindTyVarsFV2Rn, extendTyVarEnvFVRn, - bindCoreLocalFVRn, bindCoreLocalsFVRn, bindLocalNames, - checkDupOrQualNames, checkDupNames, - FreeVars, emptyFVs, plusFV, plusFVs, unitFV, - addOneFV, mapFvRn + bindTyVarsRn, bindTyVars2Rn, + bindTyVarsFV2Rn, extendTyVarEnvFVRn, + bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames, + checkDupOrQualNames, checkDupNames, mapFvRn ) import RnMonad @@ -103,13 +102,13 @@ rnDecl (ValD binds) = rnTopBinds binds `thenRn` \ (new_binds, fvs) -> returnRn (ValD new_binds, fvs) rnDecl (TyClD tycl_decl) - = rnTyClDecl tycl_decl `thenRn` \ new_decl -> - rnClassBinds new_decl `thenRn` \ (new_decl', fvs) -> + = rnTyClDecl tycl_decl `thenRn` \ new_decl -> + rnClassBinds tycl_decl new_decl `thenRn` \ (new_decl', fvs) -> returnRn (TyClD new_decl', fvs `plusFV` tyClDeclFVs new_decl') rnDecl (InstD inst) = rnInstDecl inst `thenRn` \ new_inst -> - rnInstBinds new_inst `thenRn` \ (new_inst', fvs) + rnInstBinds inst new_inst `thenRn` \ (new_inst', fvs) -> returnRn (InstD new_inst, fvs `plusFV` instDeclFVs new_inst') rnDecl (RuleD rule) @@ -117,7 +116,8 @@ rnDecl (RuleD rule) = rnIfaceRuleDecl rule `thenRn` \ new_rule -> returnRn (RuleD new_rule, ruleDeclFVs new_rule) | otherwise - = rnHsRuleDecl rule + = rnHsRuleDecl rule `thenRn` \ (new_rule, fvs) -> + returnRn (RuleD new_rule, fvs) rnDecl (DefD (DefaultDecl tys src_loc)) = pushSrcLocRn src_loc $ @@ -173,15 +173,14 @@ rnInstDecl (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) ) `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 + returnRn (InstDecl inst_ty' EmptyMonoBinds [] maybe_dfun_name src_loc) -- Compare rnClassBinds rnInstBinds (InstDecl _ mbinds uprags _ _ ) - (InstDecl inst_ty mbinds uprags maybe_dfun_rdr_name src_loc) + (InstDecl inst_ty _ _ maybe_dfun_rdr_name src_loc) = let + meth_doc = text "the bindings in an instance declaration" + meth_names = collectLocatedMonoBinders mbinds inst_tyvars = case inst_ty of HsForAllTy (Just inst_tyvars) _ _ -> inst_tyvars other -> [] @@ -207,7 +206,7 @@ rnInstBinds (InstDecl _ mbinds uprags _ _ ) -- -- But the (unqualified) method names are in scope bindLocalNames binders ( - renameSigs (okInstDclSig binder_set) uprags + renameSigsFVs (okInstDclSig binder_set) uprags ) `thenRn` \ (uprags', prag_fvs) -> returnRn (InstDecl inst_ty mbinds' uprags' maybe_dfun_rdr_name src_loc, @@ -225,7 +224,7 @@ 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' -> + mapRn rnCoreExpr args `thenRn` \ args' -> rnCoreExpr rhs `thenRn` \ rhs' -> returnRn (IfaceRule rule_name vars' fn' args' rhs' src_loc) @@ -295,7 +294,7 @@ rnTyClDecl (TyData new_or_data context tycon tyvars condecls nconstrs derivings bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenRn` \ context' -> checkDupOrQualNames data_doc con_names `thenRn_` - mapFvRn rnConDecl condecls `thenRn` \ condecls' -> + mapRn rnConDecl condecls `thenRn` \ condecls' -> lookupSysBinder gen_name1 `thenRn` \ name1' -> lookupSysBinder gen_name2 `thenRn` \ name2' -> rnDerivs derivings `thenRn` \ derivings' -> @@ -358,11 +357,10 @@ rnTyClDecl (ClassDecl context cname tyvars fds sigs mbinds names src_loc) -- 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) + returnRn (ClassDecl context' cname' tyvars' fds' (non_ops' ++ sigs') EmptyMonoBinds 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 $ @@ -414,6 +412,8 @@ rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- G newLocalsRn mkLocalName gen_rdr_tyvars_w_locs `thenRn` \ gen_tyvars -> rnMethodBinds gen_tyvars mbinds `thenRn` \ (mbinds', meth_fvs) -> returnRn (ClassDecl context cname tyvars fds sigs mbinds' names src_loc, meth_fvs) + where + meth_doc = text "the default-methods for class" <+> ppr cname \end{code} @@ -424,14 +424,14 @@ rnClassBinds (ClassDecl _ _ _ _ _ mbinds _ _ ) -- G %********************************************************* \begin{code} -rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name], FreeVars) +rnDerivs :: Maybe [RdrName] -> RnMS (Maybe [Name]) rnDerivs Nothing -- derivs not specified - = returnRn (Nothing, emptyFVs) + = returnRn Nothing rnDerivs (Just clss) = mapRn do_one clss `thenRn` \ clss' -> - returnRn (Just clss', mkNameSet clss') + returnRn (Just clss') where do_one cls = lookupOccRn cls `thenRn` \ clas_name -> checkRn (getUnique clas_name `elem` derivableClassKeys) @@ -595,7 +595,7 @@ rnHsType doc (HsListTy ty) 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' -> + = mapRn (rnHsType doc) tys `thenRn` \ tys' -> returnRn (HsTupleTy (HsTupCon n' boxity) tys') where n' = tupleTyCon_name boxity (length tys) @@ -611,8 +611,8 @@ rnHsType doc (HsPredTy pred) returnRn (HsPredTy pred') rnHsType doc (HsUsgForAllTy uv_rdr ty) - = bindUVarRn doc uv_rdr $ \ uv_name -> - rnHsType doc ty `thenRn` \ ty' -> + = bindUVarRn uv_rdr $ \ uv_name -> + rnHsType doc ty `thenRn` \ ty' -> returnRn (HsUsgForAllTy uv_name ty') rnHsType doc (HsUsgTy usg ty) @@ -646,7 +646,7 @@ rnHsTupConWkr (HsTupCon n boxity) \begin{code} rnForAll doc forall_tyvars ctxt ty - = bindTyVarsFVRn doc forall_tyvars $ \ new_tyvars -> + = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> rnContext doc ctxt `thenRn` \ new_ctxt -> rnHsType doc ty `thenRn` \ new_ty -> returnRn (mkHsForAllTy (Just new_tyvars) new_ctxt new_ty) @@ -691,21 +691,18 @@ rnPred doc (HsPIParam n ty) \end{code} \begin{code} -rnFds :: SDoc -> [FunDep RdrName] -> RnMS ([FunDep Name], FreeVars) +rnFds :: SDoc -> [FunDep RdrName] -> RnMS [FunDep Name] rnFds doc fds - = mapAndUnzipRn rn_fds fds `thenRn` \ (theta, fvs_s) -> - returnRn (theta, plusFVs fvs_s) + = mapRn rn_fds fds where rn_fds (tys1, tys2) - = rnHsTyVars doc tys1 `thenRn` \ (tys1', fvs1) -> - rnHsTyVars doc tys2 `thenRn` \ (tys2', fvs2) -> - returnRn ((tys1', tys2'), fvs1 `plusFV` fvs2) + = rnHsTyVars doc tys1 `thenRn` \ tys1' -> + rnHsTyVars doc tys2 `thenRn` \ tys2' -> + returnRn (tys1', tys2') -rnHsTyVars doc tvs = mapFvRn (rnHsTyvar doc) tvs -rnHsTyvar doc tyvar - = lookupOccRn tyvar `thenRn` \ tyvar' -> - returnRn (tyvar', unitFV tyvar') +rnHsTyVars doc tvs = mapRn (rnHsTyvar doc) tvs +rnHsTyvar doc tyvar = lookupOccRn tyvar \end{code} %********************************************************* @@ -761,7 +758,7 @@ rnCoreExpr (UfApp fun arg) rnCoreExpr (UfCase scrut bndr alts) = rnCoreExpr scrut `thenRn` \ scrut' -> - bindCoreLocalFVRn bndr $ \ bndr' -> + bindCoreLocalRn bndr $ \ bndr' -> mapRn rnCoreAlt alts `thenRn` \ alts' -> returnRn (UfCase scrut' bndr' alts') @@ -793,10 +790,8 @@ rnCoreExpr (UfLet (UfRec pairs) body) \begin{code} rnCoreBndr (UfValBinder name ty) thing_inside = rnHsType doc ty `thenRn` \ ty' -> - bindCoreLocalFVRn name ( \ name' -> - thing_inside (UfValBinder name' ty') - ) `thenRn` \ (result, fvs2) -> - returnRn (result, fvs1 `plusFV` fvs2) + bindCoreLocalRn name $ \ name' -> + thing_inside (UfValBinder name' ty') where doc = text "unfolding id" diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index c3dd6e4..1d73c5b 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -16,10 +16,9 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), import CoreLint ( beginPass, endPass ) import CoreSyn import CSE ( cseProgram ) -import Rules ( RuleBase, ProtoCoreRule(..), pprProtoCoreRule, prepareLocalRuleBase, - prepareOrphanRuleBase, unionRuleBase, localRule ) +import Rules ( RuleBase, extendRuleBaseList, addRuleBaseFVs ) import CoreUnfold -import PprCore ( pprCoreBindings ) +import PprCore ( pprCoreBindings, pprCoreRulePair ) import OccurAnal ( occurAnalyseBinds ) import CoreUtils ( exprIsTrivial, etaReduceExpr, coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) @@ -53,27 +52,25 @@ import List ( partition ) \begin{code} core2core :: DynFlags + -> PackageRuleBase -- Rule-base accumulated from imported packages + -> HomeSymbolTable -> [CoreToDo] -- Spec of what core-to-core passes to do -> [CoreBind] -- Binds in - -> [ProtoCoreRule] -- Rules in - -> IO ([CoreBind], RuleBase) -- binds, local orphan rules out + -> [IdCoreRule] -- Rules in + -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out -core2core dflags core_todos binds rules +core2core dflags pkg_rule_base hst core_todos binds rules = do us <- mkSplitUniqSupply 's' let (cp_us, ru_us) = splitUniqSupply us - let (local_rules, imported_rules) = partition localRule rules + -- COMPUTE THE RULE BASE TO USE + (rule_base, binds1, orphan_rules) <- prepareRules pkg_rule_base hst binds rules - better_local_rules <- simplRules dflags ru_us local_rules binds - let (binds1, local_rule_base) = prepareLocalRuleBase binds better_local_rules - imported_rule_base = prepareOrphanRuleBase imported_rules - - -- Do the main business - (stats, processed_binds, processed_local_rules) - <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 local_rule_base - imported_rule_base Nothing core_todos + -- DO THE BUSINESS + (stats, processed_binds) + <- doCorePasses dflags (zeroSimplCount dflags) cp_us binds1 rule_base core_todos dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" @@ -81,61 +78,54 @@ core2core dflags core_todos binds rules -- Return results -- We only return local orphan rules, i.e., local rules not attached to an Id - return (processed_binds, processed_local_rules) + -- The bindings cotain more rules, embedded in the Ids + return (processed_binds, orphan_rules) doCorePasses :: DynFlags + -> RuleBase -- the main rule base -> SimplCount -- simplifier stats -> UniqSupply -- uniques -> [CoreBind] -- local binds in (with rules attached) - -> RuleBase -- local orphan rules - -> RuleBase -- imported and builtin rules - -> Maybe RuleBase -- combined rulebase, or Nothing to ask for it to be rebuilt -> [CoreToDo] -- which passes to do - -> IO (SimplCount, [CoreBind], RuleBase) -- stats, binds, local orphan rules + -> IO (SimplCount, [CoreBind]) -- stats, binds, local orphan rules -doCorePasses dflags stats us binds lrb irb rb0 [] - = return (stats, binds, lrb) +doCorePasses dflags rb stats us binds [] + = return (stats, binds) -doCorePasses dflags stats us binds lrb irb rb0 (to_do : to_dos) +doCorePasses dflags rb stats us binds (to_do : to_dos) = do let (us1, us2) = splitUniqSupply us - -- recompute rulebase if necessary - let rb = maybe (irb `unionRuleBase` lrb) id rb0 - - (stats1, binds1, mlrb1) <- doCorePass dflags us1 binds lrb rb to_do + (stats1, binds1, mlrb1) <- doCorePass dflags rb us1 binds to_do - -- request rulebase recomputation if pass returned a new local rulebase - let (lrb1,rb1) = maybe (lrb, Just rb) (\ lrb1 -> (lrb1, Nothing)) mlrb1 + doCorePasses dflags rb (stats `plusSimplCount` stats1) us2 binds1 to_dos - doCorePasses dflags (stats `plusSimplCount` stats1) us2 binds1 lrb1 irb rb1 to_dos - -doCorePass dfs us binds lrb rb (CoreDoSimplify sw_chkr) +doCorePass dfs rb us binds (CoreDoSimplify sw_chkr) = _scc_ "Simplify" simplifyPgm dfs rb sw_chkr us binds -doCorePass dfs us binds lrb rb CoreCSE +doCorePass dfs rb us binds CoreCSE = _scc_ "CommonSubExpr" noStats dfs (cseProgram dfs binds) -doCorePass dfs us binds lrb rb CoreLiberateCase +doCorePass dfs rb us binds CoreLiberateCase = _scc_ "LiberateCase" noStats dfs (liberateCase dfs binds) -doCorePass dfs us binds lrb rb CoreDoFloatInwards +doCorePass dfs rb us binds CoreDoFloatInwards = _scc_ "FloatInwards" noStats dfs (floatInwards dfs binds) -doCorePass dfs us binds lrb rb (CoreDoFloatOutwards f) +doCorePass dfs rb us binds (CoreDoFloatOutwards f) = _scc_ "FloatOutwards" noStats dfs (floatOutwards dfs f us binds) -doCorePass dfs us binds lrb rb CoreDoStaticArgs +doCorePass dfs rb us binds CoreDoStaticArgs = _scc_ "StaticArgs" noStats dfs (doStaticArgs us binds) -doCorePass dfs us binds lrb rb CoreDoStrictness +doCorePass dfs rb us binds CoreDoStrictness = _scc_ "Stranal" noStats dfs (saBinds dfs binds) -doCorePass dfs us binds lrb rb CoreDoWorkerWrapper +doCorePass dfs rb us binds CoreDoWorkerWrapper = _scc_ "WorkWrap" noStats dfs (wwTopBinds dfs us binds) -doCorePass dfs us binds lrb rb CoreDoSpecialising +doCorePass dfs rb us binds CoreDoSpecialising = _scc_ "Specialise" noStats dfs (specProgram dfs us binds) -doCorePass dfs us binds lrb rb CoreDoCPResult +doCorePass dfs rb us binds CoreDoCPResult = _scc_ "CPResult" noStats dfs (cprAnalyse dfs binds) -doCorePass dfs us binds lrb rb CoreDoPrintCore +doCorePass dfs us binds CoreDoPrintCore = _scc_ "PrintCore" noStats dfs (printCore binds) -doCorePass dfs us binds lrb rb CoreDoUSPInf - = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds lrb) -doCorePass dfs us binds lrb rb CoreDoGlomBinds +doCorePass dfs rb us binds CoreDoUSPInf + = _scc_ "CoreUsageSPInf" noStats dfs (doUsageSPInf dfs us binds) +doCorePass dfs rb us binds CoreDoGlomBinds = noStats dfs (glomBinds dfs binds) printCore binds = do dumpIfSet True "Print Core" @@ -143,7 +133,7 @@ printCore binds = do dumpIfSet True "Print Core" return binds -- most passes return no stats and don't change rules -noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds, Nothing) } +noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds) } \end{code} @@ -154,48 +144,104 @@ noStats dfs thing = do { binds <- thing; return (zeroSimplCount dfs, binds, Noth %* * %************************************************************************ -We must do some gentle simplification on the template (but not the RHS) -of each rule. The case that forced me to add this was the fold/build rule, -which without simplification looked like: - fold k z (build (/\a. g a)) ==> ... -This doesn't match unless you do eta reduction on the build argument. +-- prepareLocalRuleBase takes the CoreBinds and rules defined in this module. +-- It attaches those rules that are for local Ids to their binders, and +-- returns the remainder attached to Ids in an IdSet. It also returns +-- Ids mentioned on LHS of some rule; these should be blacklisted. + +-- 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 \begin{code} -simplRules :: DynFlags -> UniqSupply -> [ProtoCoreRule] -> [CoreBind] - -> IO [ProtoCoreRule] -simplRules dflags us rules binds - = do let (better_rules,_) - = initSmpl dflags sw_chkr us bind_vars black_list_all - (mapSmpl simplRule rules) - - dumpIfSet_dyn dflags Opt_D_dump_rules - "Transformation rules" - (vcat (map pprProtoCoreRule better_rules)) - - return better_rules +prepareRules :: DynFlags -> PackageRuleBase -> HomeSymbolTable + -> UniqSupply + -> [CoreBind] -> [IdCoreRule] -- Local bindings and rules + -> IO (RuleBase, -- Full rule base + [CoreBind], -- Bindings augmented with rules + [IdCoreRule]) -- Orphan rules + +prepareRules dflags pkg_rule_base hst us binds rules + = do { let (better_rules,_) = initSmpl dflags sw_chkr us local_ids black_list_all + (mapSmpl simplRule rules) + + ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" + (vcat (map pprCoreRulePair better_rules)) + + ; let (local_id_rules, orphan_rules) = partition (`elemVarSet` local_ids . fst) better_rules + (binds1, local_rule_fvs) = addRulesToBinds binds local_id_rules + imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hst) + rule_base = extendRuleBaseList imp_rule_base orphan_rules + final_rule_base = addRuleBaseFVs rule_base local_rule_fvs + -- The last step black-lists the free vars of local rules too + + ; return (rule_base, binds1, orphan_rules) + } where + sw_chkr any = SwBool False -- A bit bogus black_list_all v = not (isDataConWrapId v) -- This stops all inlining except the -- wrappers for data constructors - sw_chkr any = SwBool False -- A bit bogus + add_rules rule_base mds = extendRuleBaseList rule_base (md_rules mds) -- Boringly, we need to gather the in-scope set. - -- Typically this thunk won't even be force, but the test in - -- simpVar fails if it isn't right, and it might conceivably matter - bind_vars = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds + -- Typically this thunk won't even be forced, but the test in + -- simpVar fails if it isn't right, and it might conceiveably matter + local_ids = foldr (unionVarSet . mkVarSet . bindersOf) emptyVarSet binds + +addRulesToBinds :: [CoreBind] -> [(Id,CoreRule)] -> ([CoreBind], FreeVars) + -- A horrible function + + -- Attach the rules for each locally-defined Id to that Id. + -- - This makes the rules easier to look up + -- - It means that transformation rules and specialisations for + -- locally defined Ids are handled uniformly + -- - It keeps alive things that are referred to only from a rule + -- (the occurrence analyser knows about rules attached to Ids) + -- - It makes sure that, when we apply a rule, the free vars + -- of the RHS are more likely to be in scope + -- + -- The LHS and RHS Ids are marked 'no-discard'. + -- This means that the binding won't be discarded EVEN if the binding + -- ends up being trivial (v = w) -- the simplifier would usually just + -- substitute w for v throughout, but we don't apply the substitution to + -- the rules (maybe we should?), so this substitution would make the rule + -- bogus. + +addRulesToBinds binds imported_rule_base local_rules + = (map zap_bind binds, rule_lhs_fvs) + where + 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 + rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids + + zap_bind (NonRec b r) = NonRec (zap_bndr b) r + zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs] + + zap_bndr bndr = case lookupVarSet rule_ids bndr of + Just bndr' -> setIdNoDiscard bndr' + Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr + | otherwise -> bndr +\end{code} + +We must do some gentle simplification on the template (but not the RHS) +of each rule. The case that forced me to add this was the fold/build rule, +which without simplification looked like: + fold k z (build (/\a. g a)) ==> ... +This doesn't match unless you do eta reduction on the build argument. -simplRule rule@(ProtoCoreRule is_local id (BuiltinRule _)) +\begin{code} +simplRule rule@(id, BuiltinRule _) = returnSmpl rule -simplRule rule@(ProtoCoreRule is_local id (Rule name bndrs args rhs)) - | not is_local - = returnSmpl rule -- No need to fiddle with imported rules - | otherwise +simplRule rule@(id, Rule name bndrs args rhs) = simplBinders bndrs $ \ bndrs' -> mapSmpl simpl_arg args `thenSmpl` \ args' -> simplExpr rhs `thenSmpl` \ rhs' -> - returnSmpl (ProtoCoreRule is_local id (Rule name bndrs' args' rhs')) + returnSmpl (id, Rule name bndrs' args' rhs') simpl_arg e -- I've seen rules in which a LHS like @@ -209,6 +255,13 @@ simpl_arg e returnSmpl (etaReduceExpr e') \end{code} + +%************************************************************************ +%* * +\subsection{Glomming} +%* * +%************************************************************************ + \begin{code} glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] -- Glom all binds together in one Rec, in case any @@ -244,6 +297,7 @@ glomBinds dflags binds -- just consumes output bandwidth \end{code} + %************************************************************************ %* * \subsection{The driver for the simplifier} @@ -255,8 +309,8 @@ simplifyPgm :: DynFlags -> RuleBase -> (SimplifierSwitch -> SwitchResult) -> UniqSupply - -> [CoreBind] -- Input - -> IO (SimplCount, [CoreBind], Maybe RuleBase) -- New bindings + -> [CoreBind] -- Input + -> IO (SimplCount, [CoreBind]) -- New bindings simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs) sw_chkr us binds @@ -278,7 +332,7 @@ simplifyPgm dflags (RuleBase imported_rule_ids rule_lhs_fvs) && not (dopt Opt_D_dump_simpl_iterations dflags)) binds' ; - return (counts_out, binds', Nothing) + return (counts_out, binds') } where max_iterations = getSimplIntSwitch sw_chkr MaxSimplifierIterations diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 172bfde..efe68cd 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,18 +5,17 @@ \begin{code} module Rules ( - RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, - prepareLocalRuleBase, prepareOrphanRuleBase, - unionRuleBase, lookupRule, addRule, addIdSpecialisations, - ProtoCoreRule(..), pprProtoCoreRule, pprRuleBase, - localRule, orphanRule + RuleBase, emptyRuleBase, extendRuleBase, extendRuleBaseList, pprRuleBase, + addRuleBaseFVs, + + lookupRule, addRule, addIdSpecialisations ) where #include "HsVersions.h" import CoreSyn -- All of it import OccurAnal ( occurAnalyseRule ) -import CoreFVs ( exprFreeVars, idRuleVars, ruleRhsFreeVars, ruleSomeLhsFreeVars ) +import CoreFVs ( exprFreeVars, ruleRhsFreeVars, ruleSomeLhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( eqExpr ) import PprCore ( pprCoreRule ) @@ -25,17 +24,14 @@ import Subst ( Subst, InScopeSet, mkInScopeSet, lookupSubst, extendSubst, bindSubstList, unBindSubstList, substInScope, uniqAway ) import Id ( Id, idUnfolding, zapLamIdInfo, - idSpecialisation, setIdSpecialisation, - setIdNoDiscard + idSpecialisation, setIdSpecialisation ) -import Name ( isLocallyDefined ) import Var ( isTyVar, isId ) import VarSet import VarEnv import Type ( mkTyVarTy ) import qualified Unify ( match ) -import UniqFM import Outputable import Maybes ( maybeToBool ) import Util ( sortLt ) @@ -207,11 +203,11 @@ matchRule in_scope rule@(Rule rn tpl_vars tpl_args rhs) args Nothing -> Nothing eta_complete other vars = Nothing --} zapOccInfo bndr | isTyVar bndr = bndr | otherwise = zapLamIdInfo bndr +-} \end{code} \begin{code} @@ -444,29 +440,10 @@ addIdSpecialisations id spec_stuff %************************************************************************ \begin{code} -data ProtoCoreRule - = ProtoCoreRule - Bool -- True <=> this rule was defined in this module, - Id -- What Id is it for - CoreRule -- The rule itself - - -pprProtoCoreRule (ProtoCoreRule _ fn rule) = pprCoreRule (ppr fn) rule - lookupRule :: InScopeSet -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) lookupRule in_scope fn args = case idSpecialisation fn of Rules rules _ -> matchRules in_scope rules args - -localRule :: ProtoCoreRule -> Bool -localRule (ProtoCoreRule local _ _) = local - -orphanRule :: ProtoCoreRule -> Bool --- An "orphan rule" is one that is defined in this --- module, but for an *imported* function. We need --- to track these separately when generating the interface file -orphanRule (ProtoCoreRule local fn _) - = local && not (isLocallyDefined fn) \end{code} @@ -485,8 +462,15 @@ data RuleBase = RuleBase IdSet -- Ids (whether local or imported) mentioned on -- LHS of some rule; these should be black listed + -- This representation is a bit cute, and I wonder if we should + -- change it to use (IdEnv CoreRule) which seems a bit more natural + emptyRuleBase = RuleBase emptyVarSet emptyVarSet +addRuleBaseFVs :: RuleBase -> IdSet -> RuleBase +addRuleBaseFVs (RuleBase rules fvs) extra_fvs + = RuleBase rules (fvs `unionVarSet` extra_fvs) + extendRuleBaseList :: RuleBase -> [(Id,CoreRule)] -> RuleBase extendRuleBaseList rule_base new_guys = foldl extendRuleBase rule_base new_guys @@ -505,75 +489,8 @@ extendRuleBase (RuleBase rule_ids rule_fvs) (id, rule) -- Find *all* the free Ids of the LHS, not just -- locally defined ones!! -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 - pprRuleBase :: RuleBase -> SDoc 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 --- returns the remainder attached to Ids in an IdSet. It also returns --- Ids mentioned on LHS of some rule; these should be blacklisted. - --- 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] -> [(Id,CoreRule)] -> ([CoreBind], RuleBase) -prepareLocalRuleBase binds local_rules - = error "urk" -{- - = (map zap_bind binds, RuleBase imported_id_rule_ids rule_lhs_fvs) - where - 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 - rule_fvs = foldVarSet (unionVarSet . idRuleVars) rule_lhs_fvs rule_ids - - -- Attach the rules for each locally-defined Id to that Id. - -- - This makes the rules easier to look up - -- - It means that transformation rules and specialisations for - -- locally defined Ids are handled uniformly - -- - It keeps alive things that are referred to only from a rule - -- (the occurrence analyser knows about rules attached to Ids) - -- - It makes sure that, when we apply a rule, the free vars - -- of the RHS are more likely to be in scope - -- - -- The LHS and RHS Ids are marked 'no-discard'. - -- This means that the binding won't be discarded EVEN if the binding - -- ends up being trivial (v = w) -- the simplifier would usually just - -- substitute w for v throughout, but we don't apply the substitution to - -- the rules (maybe we should?), so this substitution would make the rule - -- bogus. - zap_bind (NonRec b r) = NonRec (zap_bndr b) r - zap_bind (Rec prs) = Rec [(zap_bndr b, r) | (b,r) <- prs] - - zap_bndr bndr = case lookupVarSet rule_ids bndr of - Just bndr' -> setIdNoDiscard bndr' - Nothing | bndr `elemVarSet` rule_fvs -> setIdNoDiscard bndr - | otherwise -> bndr --} - -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 - = 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 55a805b..3154f84 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -11,7 +11,7 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds, #include "HsVersions.h" import HsSyn ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..), - HsExpr(..), HsLit(..), HsType(..), HsPred(..), + HsExpr(..), HsLit(..), HsType(..), HsPred(..), mkSimpleMatch, andMonoBinds, andMonoBindList, isClassDecl, isClassOpSig, isPragSig, getClassDeclSysNames, tyClDeclName @@ -37,8 +37,8 @@ import TcType ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars ) import TcMonad import Generics ( mkGenericRhs, validGenericMethodType ) import PrelInfo ( nO_METHOD_BINDING_ERROR_ID ) -import Class ( classTyVars, classBigSig, classSelIds, classTyCon, - Class, ClassOpItem, DefMeth (..) ) +import Class ( classTyVars, classBigSig, classSelIds, classTyCon, classTvsFds, + Class, ClassOpItem, DefMeth (..), FunDep ) import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId ) import DataCon ( mkDataCon, notMarkedStrict ) import Id ( Id, idType, idName ) @@ -47,7 +47,7 @@ import Name ( Name, isLocallyDefined, NamedThing(..), plusNameEnv, nameEnvElts ) import NameSet ( emptyNameSet ) import Outputable -import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred, +import Type ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred, splitTyConApp_maybe, isTyVarTy ) import Var ( TyVar ) @@ -128,7 +128,7 @@ tcClassDecl1 rec_env tcSuperClasses clas context sc_sel_names `thenTc` \ (sc_theta, sc_sel_ids) -> -- CHECK THE CLASS SIGNATURES, - mapTc (tcClassSig rec_env tyvar_names clas tyvars fds dm_info) + mapTc (tcClassSig rec_env clas tyvars fds dm_info) op_sigs `thenTc` \ sig_stuff -> -- MAKE THE CLASS DETAILS @@ -237,7 +237,6 @@ 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] @@ -251,7 +250,7 @@ tcClassSig :: TcEnv -- Knot tying only! -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the -- Class.DefMeth data structure. -tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info +tcClassSig rec_env clas clas_tyvars fds dm_info (ClassOpSig op_name maybe_dm op_ty src_loc) = tcAddSrcLoc src_loc $ @@ -260,9 +259,12 @@ tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info tcHsSigType op_ty `thenTc` \ local_ty -> let - theta = [mkClassPred clas (mkTyVarTys clas_tyvars)] - global_ty = mkSigmaTy clas_tyvars theta local_ty + theta = [mkClassPred clas (mkTyVarTys clas_tyvars)] + in + -- Check for ambiguous class op types + checkAmbiguity True clas_tyvars theta local_ty `thenTc` \ global_ty -> + let -- Build the selector id and default method id sel_id = mkDictSelId op_name clas @@ -274,12 +276,7 @@ tcClassSig rec_env tyvar_names clas clas_tyvars fds 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/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index ac28035..a654b7f 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -16,10 +16,9 @@ import RnHsSyn ( RenamedHsBinds, RenamedMonoBinds ) import CmdLineOpts ( DynFlag(..), DynFlags ) import TcMonad -import TcEnv ( TcEnv, tcSetInstEnv, newDFunName ) +import TcEnv ( TcEnv, tcSetInstEnv, newDFunName, InstInfo(..), pprInstInfo ) import TcGenDeriv -- Deriv stuff -import InstEnv ( InstInfo(..), InstEnv, - pprInstInfo, simpleDFunClassTyCon, extendInstEnv ) +import InstEnv ( InstEnv, simpleDFunClassTyCon, extendInstEnv ) import TcSimplify ( tcSimplifyThetas ) import RnBinds ( rnMethodBinds, rnTopMonoBinds ) diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 4d345fa..5c73d8a 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -8,8 +8,10 @@ module TcEnv( tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, tcEnvTyVars, getTcGST, getTcGEnv, - -- Instance environment + -- Instance environment, and InstInfo type tcGetInstEnv, tcSetInstEnv, + InstInfo(..), pprInstInfo, + simpleInstInfoTy, simpleInstInfoTyCon, isLocalInst, -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, @@ -37,19 +39,20 @@ module TcEnv( #include "HsVersions.h" +import RnHsSyn ( RenamedMonoBinds, RenamedSig ) import TcMonad import TcType ( TcKind, TcType, TcTyVar, TcTyVarSet, TcThetaType, tcInstTyVars, zonkTcTyVars, ) -import Id ( mkUserLocal, isDataConWrapId_maybe ) +import Id ( idName, mkUserLocal, isDataConWrapId_maybe ) import IdInfo ( vanillaIdInfo ) import MkId ( mkSpecPragmaId ) import Var ( TyVar, Id, idType, lazySetIdInfo, idInfo ) import VarSet -import Type ( Type, +import Type ( Type, ThetaType, tyVarsOfTypes, splitForAllTys, splitRhoTy, - getDFunTyKey + getDFunTyKey, splitTyConApp_maybe ) import DataCon ( DataCon ) import TyCon ( TyCon ) @@ -57,18 +60,18 @@ import Class ( Class, ClassOpItem, ClassContext ) import Subst ( substTy ) import Name ( Name, OccName, NamedThing(..), nameOccName, nameModule, getSrcLoc, mkGlobalName, - isLocallyDefined, + isLocallyDefined, nameModule, NameEnv, lookupNameEnv, nameEnvElts, extendNameEnvList, emptyNameEnv ) import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString ) +import HscTypes ( DFunId ) import Module ( Module ) -import HscTypes ( InstEnv, lookupTypeEnv, TyThing(..), - GlobalSymbolTable ) +import InstEnv ( InstEnv, emptyInstEnv ) +import HscTypes ( lookupTypeEnv, TyThing(..), GlobalSymbolTable ) import Util ( zipEqual ) import SrcLoc ( SrcLoc ) import Outputable -import InstEnv ( emptyInstEnv ) import IOExts ( newIORef ) \end{code} @@ -484,6 +487,50 @@ tcSetInstEnv ie thing_inside %************************************************************************ %* * +\subsection{The InstInfo type} +%* * +%************************************************************************ + +The InstInfo type summarises the information in an instance declaration + + instance c => k (t tvs) where b + +\begin{code} +data InstInfo + = InstInfo { + iClass :: Class, -- Class, k + iTyVars :: [TyVar], -- Type variables, tvs + iTys :: [Type], -- The types at which the class is being instantiated + iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the + -- instance declaration. It constrains (some of) + -- the TyVars above + iLocal :: Bool, -- True <=> it's defined in this module + iDFunId :: DFunId, -- The dfun id + iBinds :: RenamedMonoBinds, -- Bindings, b + iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn + iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances + } + +pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), + nest 4 (ppr (iBinds info))] + +simpleInstInfoTy :: InstInfo -> Type +simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty + +simpleInstInfoTyCon :: InstInfo -> TyCon + -- Gets the type constructor for a simple instance declaration, + -- i.e. one of the form instance (...) => C (T a b c) where ... +simpleInstInfoTyCon inst + = case splitTyConApp_maybe (simpleInstInfoTy inst) of + Just (tycon, _) -> tycon + +isLocalInst :: Module -> InstInfo -> Bool +isLocalInst mod info = mod == nameModule (idName (iDFunId info)) +\end{code} + + +%************************************************************************ +%* * \subsection{Errors} %* * %************************************************************************ diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index b2298bf..a7e7d9f 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -30,11 +30,10 @@ import TcDeriv ( tcDeriving ) import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcExtendTyVarEnvForMeths, tcAddImportedIdInfo, tcInstId, tcLookupClass, + InstInfo(..), pprInstInfo, simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst, newDFunName, tcExtendTyVarEnv ) -import InstEnv ( InstInfo(..), InstEnv, pprInstInfo, classDataCon, - simpleInstInfoTyCon, simpleInstInfoTy, isLocalInst, - extendInstEnv ) +import InstEnv ( InstEnv, classDataCon, extendInstEnv ) import TcMonoType ( tcTyVars, tcHsSigType, kcHsSigType ) import TcSimplify ( tcSimplifyAndCheck ) import TcType ( zonkTcSigTyVars ) @@ -191,7 +190,7 @@ tcInstDecls1 inst_env0 prs hst unf_env get_fixity mod local_tycons decls -- The result of (b) replaces the cached InstEnv in the PCS let (local_inst_info, imported_inst_info) - = partition isLocalInst (concat inst_infos) + = partition (isLocalInst mod) (concat inst_infos) imported_dfuns = map (tcAddImportedIdInfo unf_env . iDFunId) imported_inst_info @@ -817,3 +816,5 @@ nonBoxedPrimCCallErr clas inst_ty methodCtxt = ptext SLIT("When checking the methods of an instance declaration") superClassCtxt = ptext SLIT("When checking the superclasses of an instance declaration") \end{code} + + diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 585f8af..9106c2e 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -25,7 +25,7 @@ import Inst ( plusLIE ) import TcBinds ( tcTopBinds ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) -import TcEnv ( TcEnv, tcExtendGlobalValEnv, tcLookupGlobal_maybe, +import TcEnv ( TcEnv, InstInfo(iDFunId), tcExtendGlobalValEnv, tcLookupGlobal_maybe, tcEnvTyCons, tcEnvClasses, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv ) @@ -33,7 +33,6 @@ import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) import TcIfaceSig ( tcInterfaceSigs ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import InstEnv ( InstInfo(..) ) import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) import TcTyDecls ( mkImplicitDataBinds ) @@ -56,7 +55,7 @@ import BasicTypes ( EP(..), Fixity ) import Bag ( isEmptyBag ) import Outputable import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, HomeIfaceTable, - PackageSymbolTable, PackageIfaceTable, DFunId, ModIface(..), + PackageSymbolTable, DFunId, ModIface(..), TypeEnv, extendTypeEnv, lookupTable, TyThing(..), groupTyThings ) import FiniteMap ( FiniteMap, delFromFM, lookupWithDefaultFM ) @@ -204,9 +203,9 @@ tcModule pcs hst get_fixity this_mod decls unf_env -- Second pass over class and instance declarations, -- to compile the bindings themselves. - tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> - tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> - tcRules (pcs_rules pcs) decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) -> + tcInstDecls2 local_inst_info `thenNF_Tc` \ (lie_instdecls, inst_binds) -> + tcClassDecls2 decls `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) -> + tcRules (pcs_rules pcs) this_mod decls `thenNF_Tc` \ (new_pcs_rules, lie_rules, local_rules) -> -- Deal with constant or ambiguous InstIds. How could -- there be ambiguous ones? They can only arise if a @@ -265,7 +264,7 @@ tcModule pcs hst get_fixity this_mod decls unf_env tc_binds = all_binds', tc_insts = map iDFunId local_inst_info, tc_fords = foi_decls ++ foe_decls', - tc_rules = rules' + tc_rules = local_rules' }) get_binds decls = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls] diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index cc7bb71..ff2b84f 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -371,10 +371,13 @@ tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) tcHsTyVars tv_names kind_check $ \ tyvars -> tcContext ctxt `thenTc` \ theta -> tcHsType ty `thenTc` \ tau -> - checkAmbiguity full_ty tyvars theta tau `thenTc_` - returnTc (mkSigmaTy tyvars theta tau) + checkAmbiguity is_source tyvars theta tau + where + is_source = case tv_names of + (UserTyVar _ : _) -> True + other -> False -checkAmbiguity :: RenamedHsType -> [TyVar] -> ThetaType -> Type -> TcM () +checkAmbiguity :: Bool -> [TyVar] -> ThetaType -> Type -> TcM Type -- Check for ambiguity -- forall V. P => tau -- is ambiguous if P contains generic variables @@ -393,25 +396,6 @@ checkAmbiguity :: RenamedHsType -> [TyVar] -> ThetaType -> Type -> TcM () -- even in a scope where b is in scope. -- This is the is_free test below. -checkAmbiguity full_ty forall_tyvars theta tau - = mapTc_ check_pred theta - where - tau_vars = tyVarsOfType tau - fds = instFunDepsOfTheta theta - tvFundep = tyVarFunDep fds - extended_tau_vars = oclose tvFundep tau_vars - - is_ambig ct_var = (ct_var `elem` forall_tyvars) && - not (ct_var `elemUFM` extended_tau_vars) - is_free ct_var = not (ct_var `elem` forall_tyvars) - - check_pred pred = checkTc (not any_ambig) (ambigErr pred full_ty) `thenTc_` - checkTc (not all_free) (freeErr pred full_ty) - where - ct_vars = varSetElems (tyVarsOfPred pred) - all_free = all is_free ct_vars - any_ambig = is_source_polytype && any is_ambig ct_vars - -- Notes on the 'is_source_polytype' test above -- Check ambiguity only for source-program types, not -- for types coming from inteface files. The latter can @@ -427,10 +411,27 @@ checkAmbiguity full_ty forall_tyvars theta tau -- If the list of tv_names is empty, we have a monotype, -- and then we don't need to check for ambiguity either, -- because the test can't fail (see is_ambig). - is_source_polytype - = case full_ty of - HsForAllTy (Just (UserTyVar _ : _)) _ _ -> True - other -> False + +checkAmbiguity is_source_polytype forall_tyvars theta tau + = mapTc_ check_pred theta `thenTc_` + returnTc sigma_ty + where + sigma_ty = mkSigmaTy forall_tyvars theta tau + tau_vars = tyVarsOfType tau + fds = instFunDepsOfTheta theta + tvFundep = tyVarFunDep fds + extended_tau_vars = oclose tvFundep tau_vars + + is_ambig ct_var = (ct_var `elem` forall_tyvars) && + not (ct_var `elemUFM` extended_tau_vars) + is_free ct_var = not (ct_var `elem` forall_tyvars) + + check_pred pred = checkTc (not any_ambig) (ambigErr pred sigma_ty) `thenTc_` + checkTc (not all_free) (freeErr pred sigma_ty) + where + ct_vars = varSetElems (tyVarsOfPred pred) + all_free = all is_free ct_vars + any_ambig = is_source_polytype && any is_ambig ct_vars \end{code} Help functions for type applications diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index a8d6a96..16fb692 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,10 +8,10 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..), isIfaceRuleDecl ) +import HsSyn ( HsDecl(..), RuleDecl(..), RuleBndr(..) ) import CoreSyn ( CoreRule(..) ) import RnHsSyn ( RenamedHsDecl, RenamedRuleDecl ) -import HscTypes ( PackageRuleEnv ) +import HscTypes ( PackageRuleBase ) import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) import TcMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck ) @@ -21,9 +21,10 @@ import TcMonoType ( kcHsSigType, tcHsSigType, tcTyVars, checkSigTyVars ) import TcExpr ( tcExpr ) import TcEnv ( tcExtendLocalValEnv, tcExtendTyVarEnv ) import Rules ( extendRuleBase ) -import Inst ( LIE, plusLIEs, instToId ) +import Inst ( LIE, emptyLIE, plusLIEs, instToId ) import Id ( idType, idName, mkVanillaId ) -import Name ( Name, extendNameEnvList ) +import Name ( nameModule ) +import Module ( Module ) import VarSet import Type ( tyVarsOfTypes, openTypeKind ) import Bag ( bagToList ) @@ -32,29 +33,35 @@ import Outputable \end{code} \begin{code} -tcRules :: PackageRuleEnv -> [RenamedHsDecl] -> TcM (PackageRuleEnv, LIE, [TypecheckedRuleDecl]) -tcRules pkg_rule_env decls - = mapAndUnzipTc tcLocalRule local_rules `thenTc` \ (lies, new_local_rules) -> - mapTc tcIfaceRule imported_rules `thenTc` \ new_imported_rules -> - returnTc (extendRuleBaseList pkg_rule_env new_imported_rules, - plusLIEs lies, new_local_rules) +tcRules :: PackageRuleBase -> Module -> [RenamedHsDecl] + -> TcM (PackageRuleBase, LIE, [TypecheckedRuleDecl]) +tcRules pkg_rule_base mod decls + = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, new_rules) -> + let + (local_rules, imported_rules) = partition is_local new_rules + new_rule_base = foldl add pkg_rule_base imported_rules + in + returnTc (new_rule_base, plusLIEs lies, local_rules) where - rule_decls = [rule | RuleD rule <- decls] - (imported_rules, local_rules) = partition isIfaceRuleDecl rule_decls + add rule_base (IfaceRuleOut id rule) = extendRuleBase rule_base (id, rule) + + -- When relinking this module from its interface-file decls + -- we'll have IfaceRules that are in fact local to this module + is_local (IfaceRuleOut n _) = mod == nameModule (idName n) + is_local other = True -tcIfaceRule :: RenamedRuleDecl -> TcM (Id, CoreRule) +tcRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl) -- No zonking necessary! -tcIfaceRule (IfaceRule name vars fun args rhs src_loc) +tcRule (IfaceRule name vars fun args rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ tcVar fun `thenTc` \ fun' -> tcCoreLamBndrs vars $ \ vars' -> mapTc tcCoreExpr args `thenTc` \ args' -> tcCoreExpr rhs `thenTc` \ rhs' -> - returnTc (fun', Rule name vars' args' rhs') + returnTc (emptyLIE, IfaceRuleOut fun' (Rule name vars' args' rhs')) -tcLocalRule :: RenamedRuleDecl -> TcM (LIE, TypecheckedRuleDecl) -tcLocalRule (HsRule name sig_tvs vars lhs rhs src_loc) +tcRule (HsRule name sig_tvs vars lhs rhs src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (ruleCtxt name) $ newTyVarTy openTypeKind `thenNF_Tc` \ rule_ty -> diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 7952aca..532729f 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -11,12 +11,13 @@ module TcTyClsDecls ( #include "HsVersions.h" import HsSyn ( HsDecl(..), TyClDecl(..), - HsType(..), HsTyVarBndr, - ConDecl(..), ConDetails(..), - Sig(..), HsPred(..), HsTupCon(..), - tyClDeclName, hsTyVarNames, isClassDecl, isSynDecl, isClassOpSig, getBangType + HsTyVarBndr, + ConDecl(..), + Sig(..), HsPred(..), + tyClDeclName, hsTyVarNames, + isIfaceSigDecl, isClassDecl, isSynDecl, isClassOpSig ) -import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, listTyCon_name ) +import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, tyClDeclFVs ) import BasicTypes ( RecFlag(..), NewOrData(..) ) import TcMonad @@ -38,15 +39,13 @@ import DataCon ( isNullaryDataCon ) import Var ( varName ) import FiniteMap import Digraph ( stronglyConnComp, SCC(..) ) -import Name ( Name, NamedThing(..), NameEnv, getSrcLoc, isTvOcc, nameOccName, - mkNameEnv, lookupNameEnv_NF +import Name ( Name, NamedThing(..), NameEnv, getSrcLoc, + mkNameEnv, lookupNameEnv_NF, isTyVarName ) +import NameSet import Outputable -import Maybes ( mapMaybe, catMaybes ) -import UniqSet ( emptyUniqSet, unitUniqSet, unionUniqSets, - unionManyUniqSets, uniqSetToList ) +import Maybes ( mapMaybe ) import ErrUtils ( Message ) -import Unique ( Unique, Uniquable(..) ) import HsDecls ( getClassDeclSysNames ) import Generics ( mkTyConGenInfo ) import CmdLineOpts ( DynFlags ) @@ -362,7 +361,7 @@ Dependency analysis sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl] sortByDependency decls = let -- CHECK FOR CLASS CYCLES - cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls) + cls_sccs = stronglyConnComp (mapMaybe mkClassEdges tycl_decls) cls_cycles = [ decls | CyclicSCC decls <- cls_sccs] in checkTc (null cls_cycles) (classCycleErr cls_cycles) `thenTc_` @@ -380,8 +379,8 @@ sortByDependency decls in returnTc decl_sccs where - tycl_decls = [d | TyClD d <- decls] - edges = map mk_edges tycl_decls + tycl_decls = [d | TyClD d <- decls, not (isIfaceSigDecl d)] + edges = map mkEdges tycl_decls is_syn_decl (d, _, _) = isSynDecl d \end{code} @@ -390,84 +389,25 @@ Edges in Type/Class decls ~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} +tyClDeclFTVs :: RenamedTyClDecl -> [Name] +tyClDeclFTVs d = foldNameSet add [] (tyClDeclFVs d) + where + add n fvs | isTyVarName n = fvs + | otherwise = n : fvs + ---------------------------------------------------- -- mk_cls_edges looks only at the context of class decls -- Its used when we are figuring out if there's a cycle in the -- superclass hierarchy -mk_cls_edges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Unique, [Unique]) - -mk_cls_edges decl@(ClassDecl ctxt name _ _ _ _ _ _) - = Just (decl, getUnique name, map getUnique (catMaybes (map get_clas ctxt))) -mk_cls_edges other_decl - = Nothing - ----------------------------------------------------- -mk_edges :: RenamedTyClDecl -> (RenamedTyClDecl, Unique, [Unique]) - -mk_edges decl@(TyData _ ctxt name _ condecls _ derivs _ _ _) - = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` - get_cons condecls `unionUniqSets` - get_deriv derivs)) - -mk_edges decl@(TySynonym name _ rhs _) - = (decl, getUnique name, uniqSetToList (get_ty rhs)) - -mk_edges decl@(ClassDecl ctxt name _ _ sigs _ _ _) - = (decl, getUnique name, uniqSetToList (get_ctxt ctxt `unionUniqSets` - get_sigs sigs)) +mkClassEdges :: RenamedTyClDecl -> Maybe (RenamedTyClDecl, Name, [Name]) +mkClassEdges decl@(ClassDecl ctxt name _ _ _ _ _ _) = Just (decl, name, [c | HsPClass c _ <- ctxt]) +mkClassEdges other_decl = Nothing ---------------------------------------------------- -get_ctxt ctxt = unionManyUniqSets (map set_name (catMaybes (map get_clas ctxt))) -get_clas (HsPClass clas _) = Just clas -get_clas _ = Nothing - ----------------------------------------------------- -get_deriv Nothing = emptyUniqSet -get_deriv (Just clss) = unionManyUniqSets (map set_name clss) - ----------------------------------------------------- -get_cons cons = unionManyUniqSets (map get_con cons) - ----------------------------------------------------- -get_con (ConDecl _ _ _ ctxt details _) - = get_ctxt ctxt `unionUniqSets` get_con_details details - ----------------------------------------------------- -get_con_details (VanillaCon btys) = unionManyUniqSets (map get_bty btys) -get_con_details (InfixCon bty1 bty2) = unionUniqSets (get_bty bty1) (get_bty bty2) -get_con_details (RecCon nbtys) = unionManyUniqSets (map (get_bty.snd) nbtys) - ----------------------------------------------------- -get_bty bty = get_ty (getBangType bty) - ----------------------------------------------------- -get_ty (HsTyVar name) | isTvOcc (nameOccName name) = emptyUniqSet - | otherwise = set_name name -get_ty (HsAppTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (HsFunTy ty1 ty2) = unionUniqSets (get_ty ty1) (get_ty ty2) -get_ty (HsListTy ty) = set_name listTyCon_name `unionUniqSets` get_ty ty -get_ty (HsTupleTy (HsTupCon n _) tys) = set_name n `unionUniqSets` get_tys tys -get_ty (HsUsgTy _ ty) = get_ty ty -get_ty (HsUsgForAllTy _ ty) = get_ty ty -get_ty (HsForAllTy _ ctxt mty) = get_ctxt ctxt `unionUniqSets` get_ty mty -get_ty (HsPredTy (HsPClass name _)) = set_name name -get_ty (HsPredTy (HsPIParam _ _)) = emptyUniqSet -- I think - ----------------------------------------------------- -get_tys tys = unionManyUniqSets (map get_ty tys) - ----------------------------------------------------- -get_sigs sigs - = unionManyUniqSets (map get_sig sigs) - where - get_sig (ClassOpSig _ _ ty _) = get_ty ty - get_sig (FixSig _) = emptyUniqSet - get_sig other = panic "TcTyClsDecls:get_sig" - ----------------------------------------------------- -set_name name = unitUniqSet (getUnique name) +mkEdges :: RenamedTyClDecl -> (RenamedTyClDecl, Name, [Name]) +mkEdges decl = (decl, tyClDeclName decl, tyClDeclFTVs decl) \end{code} diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index ed97975..0129d0c 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,30 +7,22 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - InstInfo(..), pprInstInfo, - simpleInstInfoTy, simpleInstInfoTyCon, simpleDFunClassTyCon, - -- Instance environment InstEnv, emptyInstEnv, extendInstEnv, lookupInstEnv, InstLookupResult(..), - classInstEnv, classDataCon, - - isLocalInst + classInstEnv, classDataCon, simpleDFunClassTyCon ) where #include "HsVersions.h" -import RnHsSyn ( RenamedMonoBinds, RenamedSig ) - import HscTypes ( InstEnv, ClsInstEnv, DFunId ) import Class ( Class ) -import Var ( TyVar, Id ) +import Var ( Id ) import VarSet ( unionVarSet, mkVarSet ) import VarEnv ( TyVarSubstEnv ) import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool ) import Name ( getSrcLoc ) -import SrcLoc ( SrcLoc ) -import Type ( Type, ThetaType, splitTyConApp_maybe, +import Type ( Type, splitTyConApp_maybe, splitSigmaTy, splitDFunTy, tyVarsOfTypes ) import PprType ( ) @@ -47,50 +39,6 @@ import CmdLineOpts -%************************************************************************ -%* * -\subsection{The InstInfo type} -%* * -%************************************************************************ - -The InstInfo type summarises the information in an instance declaration - - instance c => k (t tvs) where b - -\begin{code} -data InstInfo - = InstInfo { - iClass :: Class, -- Class, k - iTyVars :: [TyVar], -- Type variables, tvs - iTys :: [Type], -- The types at which the class is being instantiated - iTheta :: ThetaType, -- inst_decl_theta: the original context, c, from the - -- instance declaration. It constrains (some of) - -- the TyVars above - iLocal :: Bool, -- True <=> it's defined in this module - iDFunId :: DFunId, -- The dfun id - iBinds :: RenamedMonoBinds, -- Bindings, b - iLoc :: SrcLoc, -- Source location assoc'd with this instance's defn - iPrags :: [RenamedSig] -- User pragmas recorded for generating specialised instances - } - -pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info)), - nest 4 (ppr (iBinds info))] - -simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy (InstInfo {iTys = [ty]}) = ty - -simpleInstInfoTyCon :: InstInfo -> TyCon - -- Gets the type constructor for a simple instance declaration, - -- i.e. one of the form instance (...) => C (T a b c) where ... -simpleInstInfoTyCon inst - = case splitTyConApp_maybe (simpleInstInfoTy inst) of - Just (tycon, _) -> tycon - -isLocalInst :: InstInfo -> Bool -isLocalInst info = iLocal info -\end{code} - - A tiny function which doesn't belong anywhere else. It makes a nasty mutual-recursion knot if you put it in Class. diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index d9cdc77..d0e55fa 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -92,10 +92,9 @@ monad. doUsageSPInf :: DynFlags -> UniqSupply -> [CoreBind] - -> RuleBase -> IO [CoreBind] -doUsageSPInf dflags us binds local_rules +doUsageSPInf dflags us binds | not opt_UsageSPOn = do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ; return binds -- 1.7.10.4