diff options
59 files changed, 2133 insertions, 1996 deletions
diff --git a/ghc/compiler/NOTES b/ghc/compiler/NOTES index e535959847..8c62750008 100644 --- a/ghc/compiler/NOTES +++ b/ghc/compiler/NOTES @@ -1,3 +1,5 @@ + +------------------------- *** unexpected failure for jtod_circint(opt) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 547ed7adde..4348e4a961 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -79,7 +79,7 @@ module Id ( #include "HsVersions.h" -import CoreSyn ( Unfolding, CoreRules, IdCoreRule(..), rulesRules ) +import CoreSyn ( Unfolding, CoreRule ) import BasicTypes ( Arity ) import Var ( Id, DictId, isId, isExportedId, isSpecPragmaId, isLocalId, @@ -403,13 +403,13 @@ setIdNewDemandInfo id dmd = modifyIdInfo (`setNewDemandInfo` Just dmd) id --------------------------------- -- SPECIALISATION -idSpecialisation :: Id -> CoreRules +idSpecialisation :: Id -> SpecInfo idSpecialisation id = specInfo (idInfo id) -idCoreRules :: Id -> [IdCoreRule] -idCoreRules id = [IdCoreRule id False rule | rule <- rulesRules (idSpecialisation id)] +idCoreRules :: Id -> [CoreRule] +idCoreRules id = specInfoRules (idSpecialisation id) -setIdSpecialisation :: Id -> CoreRules -> Id +setIdSpecialisation :: Id -> SpecInfo -> Id setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id --------------------------------- diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 572c974e4a..5f223e5ec4 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -63,7 +63,8 @@ module IdInfo ( occInfo, setOccInfo, -- Specialisation - specInfo, setSpecInfo, + SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + specInfoFreeVars, specInfoRules, seqSpecInfo, -- CAF info CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs, @@ -79,6 +80,7 @@ import CoreSyn import Class ( Class ) import PrimOp ( PrimOp ) import Var ( Id ) +import VarSet ( VarSet, emptyVarSet, seqVarSet ) import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -282,7 +284,7 @@ case. KSW 1999-04). data IdInfo = IdInfo { arityInfo :: !ArityInfo, -- Its arity - specInfo :: CoreRules, -- Specialisations of this function which exist + specInfo :: SpecInfo, -- Specialisations of this function which exist #ifdef OLD_STRICTNESS cprInfo :: CprInfo, -- Function always constructs a product result demandInfo :: Demand.Demand, -- Whether or not it is definitely demanded @@ -317,7 +319,7 @@ seqIdInfo (IdInfo {}) = () megaSeqIdInfo :: IdInfo -> () megaSeqIdInfo info - = seqRules (specInfo info) `seq` + = seqSpecInfo (specInfo info) `seq` seqWorker (workerInfo info) `seq` -- Omitting this improves runtimes a little, presumably because @@ -385,7 +387,7 @@ vanillaIdInfo demandInfo = wwLazy, strictnessInfo = NoStrictnessInfo, #endif - specInfo = emptyCoreRules, + specInfo = emptySpecInfo, workerInfo = NoWorker, unfoldingInfo = noUnfolding, lbvarInfo = NoLBVarInfo, @@ -445,6 +447,33 @@ type InlinePragInfo = Activation %************************************************************************ %* * + SpecInfo +%* * +%************************************************************************ + +\begin{code} +-- CoreRules is used only in an idSpecialisation (move to IdInfo?) +data SpecInfo + = SpecInfo [CoreRule] VarSet -- Locally-defined free vars of RHSs + +emptySpecInfo :: SpecInfo +emptySpecInfo = SpecInfo [] emptyVarSet + +isEmptySpecInfo :: SpecInfo -> Bool +isEmptySpecInfo (SpecInfo rs _) = null rs + +specInfoFreeVars :: SpecInfo -> VarSet +specInfoFreeVars (SpecInfo _ fvs) = fvs + +specInfoRules :: SpecInfo -> [CoreRule] +specInfoRules (SpecInfo rules _) = rules + +seqSpecInfo (SpecInfo rules fvs) = seqRules rules `seq` seqVarSet fvs +\end{code} + + +%************************************************************************ +%* * \subsection[worker-IdInfo]{Worker info about an @Id@} %* * %************************************************************************ diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 3443a73472..337d6a4cfb 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -37,12 +37,12 @@ module MkId ( import BasicTypes ( Arity, StrictnessMark(..), isMarkedUnboxed, isMarkedStrict ) +import Rules ( mkSpecInfo ) import TysPrim ( openAlphaTyVars, alphaTyVar, alphaTy, realWorldStatePrimTy, addrPrimTy ) import TysWiredIn ( charTy, mkListTy ) import PrelRules ( primOpRules ) -import Rules ( addRules ) import Type ( TyThing(..) ) import TcType ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy, mkTyConApp, mkTyVarTys, mkClassPred, tcEqPred, @@ -665,13 +665,10 @@ mkPrimOpId prim_op id = mkGlobalId (PrimOpId prim_op) name ty info info = noCafIdInfo - `setSpecInfo` rules - `setArityInfo` arity + `setSpecInfo` mkSpecInfo (primOpRules prim_op name) + `setArityInfo` arity `setAllStrictnessInfo` Just strict_sig - rules = addRules id emptyCoreRules (primOpRules prim_op) - - -- For each ccall we manufacture a separate CCallOpId, giving it -- a fresh unique, a type that is correct for this particular ccall, -- and a CCall structure that gives the correct details about calling @@ -717,11 +714,9 @@ Dict funs and default methods are *not* ImplicitIds. Their definition involves user-written code, so we can't figure out their strictness etc based on fixed info, as we can for constructors and record selectors (say). -We build them as GlobalIds, but when in the module where they are -bound, we turn the Id at the *binding site* into an exported LocalId. -This ensures that they are taken to account by free-variable finding -and dependency analysis (e.g. CoreFVs.exprFreeVars). The simplifier -will propagate the LocalId to all occurrence sites. +We build them as LocalIds, but with External Names. This ensures that +they are taken to account by free-variable finding and dependency +analysis (e.g. CoreFVs.exprFreeVars). Why shouldn't they be bound as GlobalIds? Because, in particular, if they are globals, the specialiser floats dict uses above their defns, diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index a508c74132..2ade6553ef 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -21,7 +21,7 @@ module Name ( setNameOcc, hashName, localiseName, - nameSrcLoc, nameParent, nameParent_maybe, + nameSrcLoc, nameParent, nameParent_maybe, isImplicitName, isSystemName, isInternalName, isExternalName, isTyVarName, isWiredInName, isBuiltInSyntax, @@ -41,7 +41,7 @@ import OccName -- All of it import Module ( Module ) import SrcLoc ( noSrcLoc, wiredInSrcLoc, SrcLoc ) import Unique ( Unique, Uniquable(..), getKey, pprUnique ) -import Maybes ( orElse ) +import Maybes ( orElse, isJust ) import Outputable \end{code} @@ -159,6 +159,11 @@ nameParent name = case nameParent_maybe name of Just parent -> parent Nothing -> name +isImplicitName :: Name -> Bool +-- An Implicit Name is one has a parent; that is, one whose definition +-- derives from tehe paren thing +isImplicitName name = isJust (nameParent_maybe name) + nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name) nameModule_maybe (Name { n_sort = External mod _}) = Just mod nameModule_maybe (Name { n_sort = WiredIn mod _ _ _}) = Just mod diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 780bda2906..00a46f0605 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -62,6 +62,7 @@ import Char ( isDigit, isUpper, isLower, isAlphaNum, ord, chr, digitToInt ) import Util ( thenCmp ) import Unique ( Unique, mkUnique, Uniquable(..) ) import BasicTypes ( Boxity(..), Arity ) +import StaticFlags ( opt_PprStyle_Debug ) import UniqFM import UniqSet import FastString @@ -524,9 +525,22 @@ mkLocalOcc uniq occ \begin{code} mkDFunOcc :: EncodedString -- Typically the class and type glommed together e.g. "OrdMaybe" - -> OccName -- "$fOrdMaybe" + -- Only used in debug mode, for extra clarity + -> Bool -- True <=> hs-boot instance dfun + -> Int -- Unique index + -> OccName -- "$f3OrdMaybe" -mkDFunOcc string = mk_deriv VarName "$f" string +-- In hs-boot files we make dict funs like $fx7ClsTy, which get bound to the real +-- thing when we compile the mother module. Reason: we don't know exactly +-- what the mother module will call it. + +mkDFunOcc info_str is_boot index + = mk_deriv VarName prefix string + where + prefix | is_boot = "$fx" + | otherwise = "$f" + string | opt_PprStyle_Debug = show index ++ info_str + | otherwise = show index \end{code} We used to add a '$m' to indicate a method, but that gives rise to bad diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index a649ebd28d..90a0efe9ee 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -55,8 +55,6 @@ import Panic ( assertPanic ) #ifdef DEBUG import Outputable #endif - -import DATA_IOREF ( readIORef ) \end{code} \begin{code} diff --git a/ghc/compiler/coreSyn/CoreFVs.lhs b/ghc/compiler/coreSyn/CoreFVs.lhs index d0045bf2fb..9d2cc8fcec 100644 --- a/ghc/compiler/coreSyn/CoreFVs.lhs +++ b/ghc/compiler/coreSyn/CoreFVs.lhs @@ -9,9 +9,11 @@ module CoreFVs ( exprsFreeVars, -- [CoreExpr] -> VarSet exprSomeFreeVars, exprsSomeFreeVars, + exprFreeNames, exprsFreeNames, - idRuleVars, idFreeVars, idFreeTyVars, - ruleRhsFreeVars, ruleLhsFreeNames, ruleLhsFreeIds, + idRuleVars, idFreeVars, idFreeTyVars, + ruleRhsFreeVars, rulesRhsFreeVars, + ruleLhsFreeNames, ruleLhsFreeIds, CoreExprWithFVs, -- = AnnExpr Id VarSet CoreBindWithFVs, -- = AnnBind Id VarSet @@ -22,8 +24,11 @@ module CoreFVs ( #include "HsVersions.h" import CoreSyn -import Id ( Id, idType, idSpecialisation ) +import Id ( Id, idType, idSpecialisation, isLocalId ) +import IdInfo ( specInfoFreeVars ) import NameSet +import UniqFM ( delFromUFM ) +import Name ( isExternalName ) import VarSet import Var ( Var, isId, isLocalVar, varName ) import Type ( tyVarsOfType ) @@ -70,8 +75,8 @@ type InterestingVarFun = Var -> Bool -- True <=> interesting \begin{code} type FV = InterestingVarFun - -> VarSet -- In scope - -> VarSet -- Free vars + -> VarSet -- In scope + -> VarSet -- Free vars union :: FV -> FV -> FV union fv1 fv2 fv_cand in_scope = fv1 fv_cand in_scope `unionVarSet` fv2 fv_cand in_scope @@ -127,7 +132,6 @@ expr_fvs (Note _ expr) = expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) --- gaw 2004 expr_fvs (Case scrut bndr ty alts) = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr (foldr (union . alt_fvs) noVars alts) @@ -141,6 +145,9 @@ expr_fvs (Let (Rec pairs) body) = addBndrs bndrs (foldr (union . expr_fvs) (expr_fvs body) rhss) where (bndrs,rhss) = unzip pairs + +--------- +exprs_fvs exprs = foldr (union . expr_fvs) noVars exprs \end{code} @@ -150,7 +157,7 @@ expr_fvs (Let (Rec pairs) body) %* * %************************************************************************ -exprFreeNames finds the free *names* of an expression, notably +exprFreeNames finds the free *external* *names* of an expression, notably including the names of type constructors (which of course do not show up in exprFreeVars). Similarly ruleLhsFreeNames. The latter is used when deciding whether a rule is an orphan. In particular, suppose that @@ -159,40 +166,37 @@ T is defined in this module; we want to avoid declaring that a rule like is an orphan. Of course it isn't, an declaring it an orphan would make the whole module an orphan module, which is bad. +There's no need to delete local binders, because they will all +be *internal* names. + \begin{code} -ruleLhsFreeNames :: IdCoreRule -> NameSet -ruleLhsFreeNames (IdCoreRule fn _ (BuiltinRule _ _)) = unitNameSet (varName fn) -ruleLhsFreeNames (IdCoreRule fn _ (Rule _ _ tpl_vars tpl_args rhs)) - = addOneToNameSet (exprsFreeNames tpl_args `del_binders` tpl_vars) (varName fn) +ruleLhsFreeNames :: CoreRule -> NameSet +ruleLhsFreeNames (BuiltinRule { ru_fn = fn }) = unitNameSet fn +ruleLhsFreeNames (Rule { ru_fn = fn, ru_bndrs = tpl_vars, ru_args = tpl_args }) + = addOneToNameSet (exprsFreeNames tpl_args) fn exprFreeNames :: CoreExpr -> NameSet -exprFreeNames (Var v) = unitNameSet (varName v) -exprFreeNames (Lit _) = emptyNameSet -exprFreeNames (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars -exprFreeNames (App e1 e2) = exprFreeNames e1 `unionNameSets` exprFreeNames e2 -exprFreeNames (Lam v e) = exprFreeNames e `delFromNameSet` varName v -exprFreeNames (Note n e) = exprFreeNames e - -exprFreeNames (Let (NonRec b r) e) = (exprFreeNames e `delFromNameSet` varName b) - `unionNameSets` exprFreeNames r - -exprFreeNames (Let (Rec prs) e) = (exprsFreeNames rs `unionNameSets` exprFreeNames e) - `del_binders` bs - where - (bs, rs) = unzip prs - --- gaw 2004 -exprFreeNames (Case e b ty as) = exprFreeNames e `unionNameSets` tyClsNamesOfType ty - `unionNameSets` - (unionManyNameSets (map altFreeNames as) `delFromNameSet` varName b) - --- Helpers -altFreeNames (_,bs,r) = exprFreeNames r `del_binders` bs +-- Find the free *external* names of an expression +exprFreeNames e + = go e + where + go (Var v) + | isExternalName n = unitNameSet n + | otherwise = emptyNameSet + where n = varName v + go (Lit _) = emptyNameSet + go (Type ty) = tyClsNamesOfType ty -- Don't need free tyvars + go (App e1 e2) = go e1 `unionNameSets` go e2 + go (Lam v e) = go e `delFromNameSet` varName v + go (Note n e) = go e + go (Let (NonRec b r) e) = go e `unionNameSets` go r + go (Let (Rec prs) e) = exprsFreeNames (map snd prs) `unionNameSets` go e + go (Case e b ty as) = go e `unionNameSets` tyClsNamesOfType ty + `unionNameSets` unionManyNameSets (map go_alt as) + + go_alt (_,_,r) = go r exprsFreeNames es = foldr (unionNameSets . exprFreeNames) emptyNameSet es - -del_binders :: NameSet -> [Var] -> NameSet -del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bndrs \end{code} %************************************************************************ @@ -204,17 +208,26 @@ del_binders names bndrs = foldl (\s b -> delFromNameSet s (varName b)) names bnd \begin{code} ruleRhsFreeVars :: CoreRule -> VarSet -ruleRhsFreeVars (BuiltinRule _ _) = noFVs -ruleRhsFreeVars (Rule str _ tpl_vars tpl_args rhs) - = rule_fvs isLocalVar emptyVarSet +ruleRhsFreeVars (BuiltinRule {}) = noFVs +ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) + = delFromUFM fvs fn + -- Hack alert! + -- Don't include the Id in its own rhs free-var set. + -- Otherwise the occurrence analyser makes bindings recursive + -- that shoudn't be. E.g. + -- RULE: f (f x y) z ==> f x (f y z) where - rule_fvs = addBndrs tpl_vars (expr_fvs rhs) + fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + +rulesRhsFreeVars :: [CoreRule] -> VarSet +rulesRhsFreeVars rules + = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet rules ruleLhsFreeIds :: CoreRule -> VarSet -- This finds all locally-defined free Ids on the LHS of the rule -ruleLhsFreeIds (BuiltinRule _ _) = noFVs -ruleLhsFreeIds (Rule _ _ tpl_vars tpl_args rhs) - = foldl delVarSet (exprsFreeVars tpl_args) tpl_vars +ruleLhsFreeIds (BuiltinRule {}) = noFVs +ruleLhsFreeIds (Rule { ru_bndrs = bndrs, ru_args = args }) + = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet \end{code} @@ -288,7 +301,7 @@ idFreeTyVars id = tyVarsOfType (idType id) -- | otherwise = emptyVarSet idRuleVars ::Id -> VarSet -idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id) +idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id) \end{code} diff --git a/ghc/compiler/coreSyn/CoreSubst.lhs b/ghc/compiler/coreSyn/CoreSubst.lhs index 2de0390af0..a4b86eadf3 100644 --- a/ghc/compiler/coreSyn/CoreSubst.lhs +++ b/ghc/compiler/coreSyn/CoreSubst.lhs @@ -8,7 +8,7 @@ module CoreSubst ( -- Substitution stuff Subst, TvSubstEnv, IdSubstEnv, InScopeSet, - substTy, substExpr, substRules, substWorker, + substTy, substExpr, substSpec, substWorker, lookupIdSubst, lookupTvSubst, emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst, @@ -24,8 +24,7 @@ module CoreSubst ( #include "HsVersions.h" import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr, - CoreRules(..), CoreRule(..), - isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding + CoreRule(..), hasUnfolding, noUnfolding ) import CoreFVs ( exprFreeVars ) import CoreUtils ( exprIsTrivial ) @@ -36,8 +35,8 @@ import VarSet import VarEnv import Var ( setVarUnique, isId ) import Id ( idType, setIdType, maybeModifyIdInfo, isLocalId ) -import IdInfo ( IdInfo, specInfo, setSpecInfo, - unfoldingInfo, setUnfoldingInfo, +import IdInfo ( IdInfo, SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo, + unfoldingInfo, setUnfoldingInfo, seqSpecInfo, WorkerInfo(..), workerExists, workerInfo, setWorkerInfo, WorkerInfo ) import Unique ( Unique ) @@ -339,13 +338,13 @@ substIdInfo :: Subst -> IdInfo -> Maybe IdInfo -- Always zaps the unfolding, to save substitution work substIdInfo subst info | nothing_to_do = Nothing - | otherwise = Just (info `setSpecInfo` substRules subst old_rules + | otherwise = Just (info `setSpecInfo` substSpec subst old_rules `setWorkerInfo` substWorker subst old_wrkr `setUnfoldingInfo` noUnfolding) where old_rules = specInfo info old_wrkr = workerInfo info - nothing_to_do = isEmptyCoreRules old_rules && + nothing_to_do = isEmptySpecInfo old_rules && not (workerExists old_wrkr) && not (hasUnfolding (unfoldingInfo info)) @@ -366,22 +365,23 @@ substWorker subst (HasWorker w a) -- via postInlineUnconditionally, hence warning) ------------------ -substRules :: Subst -> CoreRules -> CoreRules +substSpec :: Subst -> SpecInfo -> SpecInfo -substRules subst rules - | isEmptySubst subst = rules -substRules subst (Rules rules rhs_fvs) - = seqRules new_rules `seq` new_rules +substSpec subst spec@(SpecInfo rules rhs_fvs) + | isEmptySubst subst + = spec + | otherwise + = seqSpecInfo new_rules `seq` new_rules where - new_rules = Rules (map do_subst rules) (substVarSet subst rhs_fvs) + new_rules = SpecInfo (map do_subst rules) (substVarSet subst rhs_fvs) - do_subst rule@(BuiltinRule _ _) = rule - do_subst (Rule name act tpl_vars lhs_args rhs) - = Rule name act tpl_vars' - (map (substExpr subst') lhs_args) - (substExpr subst' rhs) + do_subst rule@(BuiltinRule {}) = rule + do_subst rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) + = rule { ru_bndrs = bndrs', + ru_args = map (substExpr subst') args, + ru_rhs = substExpr subst' rhs } where - (subst', tpl_vars') = substBndrs subst tpl_vars + (subst', bndrs') = substBndrs subst bndrs ------------------ substVarSet subst fvs diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs index eb790d1693..2f6efd4127 100644 --- a/ghc/compiler/coreSyn/CoreSyn.lhs +++ b/ghc/compiler/coreSyn/CoreSyn.lhs @@ -32,19 +32,16 @@ module CoreSyn ( hasUnfolding, hasSomeUnfolding, neverUnfold, -- Seq stuff - seqRules, seqExpr, seqExprs, seqUnfolding, + seqExpr, seqExprs, seqUnfolding, -- Annotated expressions AnnExpr, AnnExpr'(..), AnnBind(..), AnnAlt, deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs, -- Core rules - CoreRules(..), -- Representation needed by friends CoreRule(..), -- CoreSubst, CoreTidy, CoreFVs, PprCore only - IdCoreRule(..), isOrphanRule, - RuleName, - emptyCoreRules, isEmptyCoreRules, rulesRhsFreeVars, rulesRules, - isBuiltinRule, ruleName + RuleName, seqRules, + isBuiltinRule, ruleName, isLocalRule, ruleIdName ) where #include "HsVersions.h" @@ -53,6 +50,8 @@ import StaticFlags ( opt_RuntimeTypes ) import CostCentre ( CostCentre, noCostCentre ) import Var ( Var, Id, TyVar, isTyVar, isId ) import Type ( Type, mkTyVarTy, seqType ) +import Name ( Name ) +import OccName ( OccName ) import Literal ( Literal, mkMachInt ) import DataCon ( DataCon, dataConWorkId, dataConTag ) import BasicTypes ( Activation ) @@ -171,56 +170,65 @@ INVARIANTS: The CoreRule type and its friends are dealt with mainly in CoreRules, but CoreFVs, Subst, PprCore, CoreTidy also inspect the representation. -\begin{code} -data CoreRules - = Rules [CoreRule] - VarSet -- Locally-defined free vars of RHSs - -emptyCoreRules :: CoreRules -emptyCoreRules = Rules [] emptyVarSet +A Rule is -isEmptyCoreRules :: CoreRules -> Bool -isEmptyCoreRules (Rules rs _) = null rs + "local" if the function it is a rule for is defined in the + same module as the rule itself. -rulesRhsFreeVars :: CoreRules -> VarSet -rulesRhsFreeVars (Rules _ fvs) = fvs - -rulesRules :: CoreRules -> [CoreRule] -rulesRules (Rules rules _) = rules -\end{code} + "orphan" if nothing on the LHS is defined in the same module + as the rule itself \begin{code} type RuleName = FastString -data IdCoreRule = IdCoreRule Id -- A rule for this Id - Bool -- True <=> orphan rule - CoreRule -- The rule itself - -isOrphanRule :: IdCoreRule -> Bool -isOrphanRule (IdCoreRule _ is_orphan _) = is_orphan data CoreRule - = Rule RuleName - Activation -- When the rule is active - [CoreBndr] -- Forall'd variables - [CoreExpr] -- LHS args - CoreExpr -- RHS + = Rule { + ru_name :: RuleName, + ru_act :: Activation, -- When the rule is active + + -- Rough-matching stuff + -- see comments with InstEnv.Instance( is_cls, is_rough ) + ru_fn :: Name, -- Name of the Id at the head of this rule + ru_rough :: [Maybe Name], -- Name at the head of each argument + + -- Proper-matching stuff + -- see comments with InstEnv.Instance( is_tvs, is_tys ) + ru_bndrs :: [CoreBndr], -- Forall'd variables + ru_args :: [CoreExpr], -- LHS args + + -- And the right-hand side + ru_rhs :: CoreExpr, + + -- Locality + ru_local :: Bool, -- The fn at the head of the rule is + -- defined in the same module as the rule + + -- Orphan-hood; see comments is InstEnv.Instance( is_orph ) + ru_orph :: Maybe OccName } + + | BuiltinRule { -- Built-in rules are used for constant folding + ru_name :: RuleName, -- and suchlike. It has no free variables. + ru_fn :: Name, -- Name of the Id at + -- the head of this rule + ru_try :: [CoreExpr] -> Maybe CoreExpr } + +isBuiltinRule (BuiltinRule {}) = True +isBuiltinRule _ = False - | BuiltinRule -- Built-in rules are used for constant folding - RuleName -- and suchlike. It has no free variables. - ([CoreExpr] -> Maybe CoreExpr) +ruleName :: CoreRule -> RuleName +ruleName = ru_name -isBuiltinRule (BuiltinRule _ _) = True -isBuiltinRule _ = False +ruleIdName :: CoreRule -> Name +ruleIdName = ru_fn -ruleName :: CoreRule -> RuleName -ruleName (Rule n _ _ _ _) = n -ruleName (BuiltinRule n _) = n +isLocalRule :: CoreRule -> Bool +isLocalRule = ru_local \end{code} %************************************************************************ %* * -\subsection{@Unfolding@ type} + Unfoldings %* * %************************************************************************ @@ -618,12 +626,10 @@ seqPairs ((b,e):prs) = seqBndr b `seq` seqExpr e `seq` seqPairs prs seqAlts [] = () seqAlts ((c,bs,e):alts) = seqBndrs bs `seq` seqExpr e `seq` seqAlts alts -seqRules :: CoreRules -> () -seqRules (Rules rules fvs) = seq_rules rules `seq` seqVarSet fvs - -seq_rules [] = () -seq_rules (Rule fs _ bs es e : rules) = seqBndrs bs `seq` seqExprs (e:es) `seq` seq_rules rules -seq_rules (BuiltinRule _ _ : rules) = seq_rules rules +seqRules [] = () +seqRules (Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs } : rules) + = seqBndrs bndrs `seq` seqExprs (rhs:args) `seq` seqRules rules +seqRules (BuiltinRule {} : rules) = seqRules rules \end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 5b879650d3..ad01474bb4 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -4,8 +4,7 @@ \begin{code} module CoreTidy ( - tidyExpr, tidyVarOcc, - tidyIdRules, pprTidyIdRules + tidyExpr, tidyVarOcc, tidyRule, tidyRules ) where #include "HsVersions.h" @@ -13,17 +12,17 @@ module CoreTidy ( import CoreSyn import CoreUtils ( exprArity ) import Unify ( coreRefineTys ) -import PprCore ( pprIdRules ) import DataCon ( DataCon, isVanillaDataCon ) import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique, - idType, setIdType, idCoreRules ) + idType, setIdType ) import IdInfo ( setArityInfo, vanillaIdInfo, newStrictnessInfo, setAllStrictnessInfo, newDemandInfo, setNewDemandInfo ) import Type ( Type, tidyType, tidyTyVarBndr, substTy, mkTvSubst ) -import Var ( Var, TyVar ) +import Var ( Var, TyVar, varName ) import VarEnv -import Name ( getOccName ) +import UniqFM ( lookupUFM ) +import Name ( Name, getOccName ) import OccName ( tidyOccName ) import SrcLoc ( noSrcLoc ) import Maybes ( orElse ) @@ -118,24 +117,24 @@ refineTidyEnv tidy_env@(occ_env, var_env) con tvs scrut_ty tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2) tidyNote env note = note - ------------ Rules -------------- -tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule] -tidyIdRules env [] = [] -tidyIdRules env (IdCoreRule fn is_orph rule : rules) +tidyRules :: TidyEnv -> [CoreRule] -> [CoreRule] +tidyRules env [] = [] +tidyRules env (rule : rules) = tidyRule env rule =: \ rule -> - tidyIdRules env rules =: \ rules -> - (IdCoreRule (tidyVarOcc env fn) is_orph rule : rules) + tidyRules env rules =: \ rules -> + (rule : rules) tidyRule :: TidyEnv -> CoreRule -> CoreRule -tidyRule env rule@(BuiltinRule _ _) = rule -tidyRule env (Rule name act vars tpl_args rhs) - = tidyBndrs env vars =: \ (env', vars) -> - map (tidyExpr env') tpl_args =: \ tpl_args -> - (Rule name act vars tpl_args (tidyExpr env' rhs)) - -pprTidyIdRules :: Id -> SDoc -pprTidyIdRules id = pprIdRules (tidyIdRules emptyTidyEnv (idCoreRules id)) +tidyRule env rule@(BuiltinRule {}) = rule +tidyRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs, + ru_fn = fn, ru_rough = mb_ns }) + = tidyBndrs env bndrs =: \ (env', bndrs) -> + map (tidyExpr env') args =: \ args -> + rule { ru_bndrs = bndrs, ru_args = args, + ru_rhs = tidyExpr env' rhs, + ru_fn = tidyNameOcc env fn, + ru_rough = map (fmap (tidyNameOcc env')) mb_ns } \end{code} @@ -146,6 +145,13 @@ pprTidyIdRules id = pprIdRules (tidyIdRules emptyTidyEnv (idCoreRules id)) %************************************************************************ \begin{code} +tidyNameOcc :: TidyEnv -> Name -> Name +-- In rules and instances, we have Names, and we must tidy them too +-- Fortunately, we can lookup in the VarEnv with a name +tidyNameOcc (_, var_env) n = case lookupUFM var_env n of + Nothing -> n + Just v -> varName v + tidyVarOcc :: TidyEnv -> Var -> Var tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 22ee21ba8a..848ca1b6bf 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -11,7 +11,7 @@ module PprCore ( pprCoreExpr, pprParendExpr, pprCoreBinding, pprCoreBindings, pprCoreAlt, - pprIdRules + pprRules ) where #include "HsVersions.h" @@ -29,7 +29,7 @@ import IdInfo ( IdInfo, megaSeqIdInfo, arityInfo, ppArityInfo, specInfo, pprNewStrictness, workerInfo, ppWorkerInfo, - newStrictnessInfo, cafInfo, ppCafInfo, + newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules ) #ifdef OLD_STRICTNESS @@ -331,7 +331,7 @@ ppIdInfo b info #endif pprNewStrictness (newStrictnessInfo info), if null rules then empty - else ptext SLIT("RULES:") <+> vcat (map (pprCoreRule (ppr b)) rules) + else ptext SLIT("RULES:") <+> vcat (map pprRule rules) -- Inline pragma, occ, demand, lbvar info -- printed out with all binders (when debug is on); -- see PprCore.pprIdBndr @@ -342,26 +342,28 @@ ppIdInfo b info s = strictnessInfo info m = cprInfo info #endif - rules = rulesRules (specInfo info) + rules = specInfoRules (specInfo info) \end{code} \begin{code} -pprIdRules :: [IdCoreRule] -> SDoc -pprIdRules rules = vcat (map pprIdRule rules) +instance Outputable CoreRule where + ppr = pprRule -pprIdRule :: IdCoreRule -> SDoc -pprIdRule (IdCoreRule id _ rule) = pprCoreRule (ppr id) rule +pprRules :: [CoreRule] -> SDoc +pprRules rules = vcat (map pprRule rules) -pprCoreRule :: SDoc -> CoreRule -> SDoc -pprCoreRule pp_fn (BuiltinRule name _) - = ptext SLIT("Built in rule for") <+> pp_fn <> colon <+> doubleQuotes (ftext name) +pprRule :: CoreRule -> SDoc +pprRule (BuiltinRule { ru_fn = fn, ru_name = name}) + = ptext SLIT("Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) -pprCoreRule pp_fn (Rule name act tpl_vars tpl_args rhs) +pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) = doubleQuotes (ftext name) <+> ppr act <+> sep [ ptext SLIT("__forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 2 (pp_fn <+> sep (map pprArg tpl_args)), + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), nest 2 (ptext SLIT("=") <+> pprCoreExpr rhs) ] <+> semi \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index c8a51514f0..2c7ddd2053 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -17,10 +17,10 @@ import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, HsBindGroup(..), LRuleDecl, HsBind(..) ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) import MkIface ( mkUsageInfo ) -import Id ( Id, setIdExported, idName, idIsFrom ) -import Name ( Name, isExternalName ) +import Id ( Id, setIdExported, idName ) +import Name ( Name, isExternalName, nameIsLocalOrFrom, nameOccName ) import CoreSyn -import PprCore ( pprIdRules, pprCoreExpr ) +import PprCore ( pprRules, pprCoreExpr ) import CoreSubst ( substExpr, mkSubst ) import DsMonad import DsExpr ( dsLExpr ) @@ -35,8 +35,9 @@ import NameSet import VarEnv import VarSet import Bag ( Bag, isEmptyBag, emptyBag, bagToList ) +import Rules ( roughTopNames ) import CoreLint ( showPass, endPass ) -import CoreFVs ( ruleRhsFreeVars ) +import CoreFVs ( ruleRhsFreeVars, exprsFreeNames ) import Packages ( PackageState(thPackageId), PackageIdH(..) ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, errorsFound, WarnMsg ) @@ -222,11 +223,12 @@ addExportFlags ghci_mode exports keep_alive prs rules | otherwise = bndr orph_rhs_fvs = unionVarSets [ ruleRhsFreeVars rule - | IdCoreRule _ is_orphan_rule rule <- rules, - is_orphan_rule ] - -- An orphan rule keeps alive the free vars of its right-hand side. - -- Non-orphan rules are (later, after gentle simplification) - -- attached to the Id and that keeps the rhs free vars alive + | rule <- rules, + not (isLocalRule rule) ] + -- A non-local rule keeps alive the free vars of its right-hand side. + -- (A "non-local" is one whose head function is not locally defined.) + -- Local rules are (later, after gentle simplification) + -- attached to the Id, and that keeps the rhs free vars alive. dont_discard bndr = is_exported name || name `elemNameSet` keep_alive @@ -248,7 +250,7 @@ addExportFlags ghci_mode exports keep_alive prs rules ppr_ds_rules [] = empty ppr_ds_rules rules = text "" $$ text "-------------- DESUGARED RULES -----------------" $$ - pprIdRules rules + pprRules rules \end{code} @@ -260,49 +262,49 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM IdCoreRule +dsRule :: Module -> IdSet -> LRuleDecl Id -> DsM CoreRule dsRule mod in_scope (L loc (HsRule name act vars lhs rhs)) = putSrcSpanDs loc $ - ds_lhs all_vars lhs `thenDs` \ (fn, args) -> - dsLExpr rhs `thenDs` \ core_rhs -> - returnDs (IdCoreRule fn (is_orphan fn) (Rule name act tpl_vars args core_rhs)) - where - tpl_vars = [var | RuleBndr (L _ var) <- vars] - all_vars = mkInScopeSet (extendVarSetList in_scope tpl_vars) - is_orphan id = not (idIsFrom mod id) - -- NB we can't use isLocalId in the orphan test, - -- because isLocalId isn't true of class methods - -ds_lhs all_vars lhs - = let - (dict_binds, body) = - case unLoc lhs of - (HsLet [HsBindGroup dict_binds _ _] body) -> (dict_binds, body) - other -> (emptyBag, lhs) - in - mappM ds_dict_bind (bagToList dict_binds) `thenDs` \ dict_binds' -> - dsLExpr body `thenDs` \ body' -> + do { let (dict_binds, body) + = case unLoc lhs of + (HsLet [HsBindGroup dbs _ _] body) -> (dbs, body) + other -> (emptyBag, lhs) + + ds_dict_bind (L _ (VarBind id rhs)) + = do { rhs' <- dsLExpr rhs ; returnDs (id,rhs') } + + ; dict_binds' <- mappM ds_dict_bind (bagToList dict_binds) + ; body' <- dsLExpr body + ; rhs' <- dsLExpr rhs -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form - let - subst = mkSubst all_vars emptyVarEnv (mkVarEnv id_pairs) - id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds'] + ; let bndrs = [var | RuleBndr (L _ var) <- vars] + in_scope' = mkInScopeSet (extendVarSetList in_scope bndrs) + subst = mkSubst in_scope' emptyVarEnv (mkVarEnv id_pairs) + id_pairs = [(id, substExpr subst rhs) | (id,rhs) <- dict_binds'] -- Note recursion here... substitution won't terminate -- if there is genuine recursion... which there isn't - body'' = substExpr subst body' - in - - -- Now unpack the resulting body - let - pair = case collectArgs body'' of - (Var fn, args) -> (fn, args) - other -> pprPanic "dsRule" (ppr lhs) - in - returnDs pair - -ds_dict_bind (L _ (VarBind id rhs)) = - dsLExpr rhs `thenDs` \ rhs' -> - returnDs (id,rhs') + body'' = substExpr subst body' + + (fn, args) = case collectArgs body'' of + (Var fn_id, args) -> (idName fn_id, args) + other -> pprPanic "dsRule" (ppr lhs) + + local_rule = nameIsLocalOrFrom mod fn + -- NB we can't use isLocalId in the orphan test, + -- because isLocalId isn't true of class methods + lhs_names = fn : nameSetToList (exprsFreeNames args) + -- No need to delete bndrs, because + -- exprsFreeNams finds only External names + orph = case filter (nameIsLocalOrFrom mod) lhs_names of + (n:ns) -> Just (nameOccName n) + [] -> Nothing + + ; return (Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs', + ru_rough = roughTopNames args, + ru_local = local_rule, ru_orph = orph }) + } \end{code} diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 6403293b5c..eac04fe139 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -562,7 +562,7 @@ showDecl exts want_name (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = 2 (equals <+> ppr mono_ty) showDecl exts want_name (IfaceData {ifName = tycon, - ifTyVars = tyvars, ifCons = condecls}) + ifTyVars = tyvars, ifCons = condecls, ifCtxt = context}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 2 (add_bars (ppr_trim show_con cs)) where @@ -593,11 +593,10 @@ showDecl exts want_name (IfaceData {ifName = tycon, = Just (ppr_bndr fld <+> dcolon <+> ppr_bangty bty) | otherwise = Nothing - (pp_nd, context, cs) = case condecls of - IfAbstractTyCon -> (ptext SLIT("data"), [], []) - IfDataTyCon (Just cxt) cs -> (ptext SLIT("data"), cxt, cs) - IfDataTyCon Nothing cs -> (ptext SLIT("data"), [], cs) - IfNewTyCon c -> (ptext SLIT("newtype"), [], [c]) + (pp_nd, cs) = case condecls of + IfAbstractTyCon -> (ptext SLIT("data"), []) + IfDataTyCon cs -> (ptext SLIT("data"), cs) + IfNewTyCon c -> (ptext SLIT("newtype"),[c]) add_bars [] = empty add_bars [c] = equals <+> c diff --git a/ghc/compiler/iface/BinIface.hs b/ghc/compiler/iface/BinIface.hs index 11e62389af..9fb0d4be66 100644 --- a/ghc/compiler/iface/BinIface.hs +++ b/ghc/compiler/iface/BinIface.hs @@ -14,6 +14,7 @@ import BasicTypes import NewDemand import IfaceSyn import VarEnv +import InstEnv ( OverlapFlag(..) ) import Packages ( PackageIdH(..) ) import Class ( DefMeth(..) ) import CostCentre @@ -635,17 +636,25 @@ instance Binary IfaceType where instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceListTc = putByte bh 1 - put_ bh IfacePArrTc = putByte bh 2 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 3; put_ bh bx; put_ bh ar } - put_ bh tc = pprPanic "BinIface.put:" (ppr tc) -- Dealt with by the IfaceType instance + + put_ bh IfaceIntTc = putByte bh 1 + put_ bh IfaceBoolTc = putByte bh 2 + put_ bh IfaceCharTc = putByte bh 3 + put_ bh IfaceListTc = putByte bh 4 + put_ bh IfacePArrTc = putByte bh 5 + put_ bh (IfaceTupTc bx ar) = do { putByte bh 6; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 7; put_ bh ext } get bh = do h <- getByte bh case h of - 1 -> return IfaceListTc - 2 -> return IfacePArrTc - _ -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + 1 -> return IfaceIntTc + 2 -> return IfaceBoolTc + 3 -> return IfaceCharTc + 4 -> return IfaceListTc + 5 -> return IfacePArrTc + 6 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } + _ -> do { ext <- get bh; return (IfaceTc ext) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -796,13 +805,13 @@ instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 put_ bh (HasInfo i) = do putByte bh 1 - lazyPut bh i + lazyPut bh i -- NB lazyPut get bh = do h <- getByte bh case h of 0 -> return NoInfo - _ -> do info <- lazyGet bh + _ -> do info <- lazyGet bh -- NB lazyGet return (HasInfo info) instance Binary IfaceInfoItem where @@ -876,7 +885,7 @@ instance Binary IfaceDecl where put_ bh idinfo put_ bh (IfaceForeign ae af) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh a1 put_ bh a2 @@ -884,6 +893,7 @@ instance Binary IfaceDecl where put_ bh a4 put_ bh a5 put_ bh a6 + put_ bh a7 put_ bh (IfaceSyn aq ar as at) = do putByte bh 3 @@ -915,7 +925,8 @@ instance Binary IfaceDecl where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceData a1 a2 a3 a4 a5 a6) + a7 <- get bh + return (IfaceData a1 a2 a3 a4 a5 a6 a7) 3 -> do aq <- get bh ar <- get bh @@ -933,27 +944,41 @@ instance Binary IfaceDecl where return (IfaceClass a1 a2 a3 a4 a5 a6 a7) instance Binary IfaceInst where - put_ bh (IfaceInst ty dfun) = do - put_ bh ty + put_ bh (IfaceInst cls tys dfun flag orph) = do + put_ bh cls + put_ bh tys put_ bh dfun - get bh = do ty <- get bh + put_ bh flag + put_ bh orph + get bh = do cls <- get bh + tys <- get bh dfun <- get bh - return (IfaceInst ty dfun) + flag <- get bh + orph <- get bh + return (IfaceInst cls tys dfun flag orph) + +instance Binary OverlapFlag where + put_ bh NoOverlap = putByte bh 0 + put_ bh OverlapOk = putByte bh 1 + put_ bh Incoherent = putByte bh 2 + get bh = do h <- getByte bh + case h of + 0 -> return NoOverlap + 1 -> return OverlapOk + 2 -> return Incoherent instance Binary IfaceConDecls where put_ bh IfAbstractTyCon = putByte bh 0 - put_ bh (IfDataTyCon st cs) = do { putByte bh 1 - ; put_ bh st - ; put_ bh cs } + put_ bh (IfDataTyCon cs) = do { putByte bh 1 + ; put_ bh cs } put_ bh (IfNewTyCon c) = do { putByte bh 2 ; put_ bh c } get bh = do h <- getByte bh case h of 0 -> return IfAbstractTyCon - 1 -> do st <- get bh - cs <- get bh - return (IfDataTyCon st cs) + 1 -> do cs <- get bh + return (IfDataTyCon cs) _ -> do aa <- get bh return (IfNewTyCon aa) @@ -1002,14 +1027,14 @@ instance Binary IfaceClassOp where return (IfaceClassOp n def ty) instance Binary IfaceRule where - -- IfaceBuiltinRule should not happen here - put_ bh (IfaceRule a1 a2 a3 a4 a5 a6) = do + put_ bh (IfaceRule a1 a2 a3 a4 a5 a6 a7) = do put_ bh a1 put_ bh a2 put_ bh a3 put_ bh a4 put_ bh a5 put_ bh a6 + put_ bh a7 get bh = do a1 <- get bh a2 <- get bh @@ -1017,6 +1042,7 @@ instance Binary IfaceRule where a4 <- get bh a5 <- get bh a6 <- get bh - return (IfaceRule a1 a2 a3 a4 a5 a6) + a7 <- get bh + return (IfaceRule a1 a2 a3 a4 a5 a6 a7) diff --git a/ghc/compiler/iface/BuildTyCl.lhs b/ghc/compiler/iface/BuildTyCl.lhs index 8624ff9349..6636d7772f 100644 --- a/ghc/compiler/iface/BuildTyCl.lhs +++ b/ghc/compiler/iface/BuildTyCl.lhs @@ -48,13 +48,14 @@ buildSynTyCon name tvs rhs_ty arg_vrcs ------------------------------------------------------ buildAlgTyCon :: Name -> [TyVar] + -> ThetaType -- Stupid theta -> AlgTyConRhs -> ArgVrcs -> RecFlag -> Bool -- True <=> want generics functions -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics - = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs +buildAlgTyCon tc_name tvs stupid_theta rhs arg_vrcs is_rec want_generics + = do { let { tycon = mkAlgTyCon tc_name kind tvs arg_vrcs stupid_theta rhs fields is_rec want_generics ; kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind ; fields = mkTyConFields tycon rhs @@ -65,9 +66,9 @@ buildAlgTyCon tc_name tvs rhs arg_vrcs is_rec want_generics mkAbstractTyConRhs :: AlgTyConRhs mkAbstractTyConRhs = AbstractTyCon -mkDataTyConRhs :: Maybe ThetaType -> [DataCon] -> AlgTyConRhs -mkDataTyConRhs mb_theta cons - = DataTyCon mb_theta cons (all isNullarySrcDataCon cons) +mkDataTyConRhs :: [DataCon] -> AlgTyConRhs +mkDataTyConRhs cons + = DataTyCon cons (all isNullarySrcDataCon cons) mkNewTyConRhs :: TyCon -> DataCon -> AlgTyConRhs mkNewTyConRhs tycon con @@ -230,7 +231,7 @@ buildClass class_name tvs sc_theta fds sig_stuff tc_isrec tc_vrcs ; rhs = case dict_component_tys of [rep_ty] -> mkNewTyConRhs tycon dict_con - other -> mkDataTyConRhs Nothing [dict_con] + other -> mkDataTyConRhs [dict_con] } ; return clas })} diff --git a/ghc/compiler/iface/IfaceEnv.lhs b/ghc/compiler/iface/IfaceEnv.lhs index d55b5e21a7..f0570cc558 100644 --- a/ghc/compiler/iface/IfaceEnv.lhs +++ b/ghc/compiler/iface/IfaceEnv.lhs @@ -63,7 +63,7 @@ newGlobalBinder :: Module -> OccName -> Maybe Name -> SrcLoc -> TcRnIf a b Name newGlobalBinder mod occ mb_parent loc = do { mod `seq` occ `seq` return () -- See notes with lookupOrig_help - ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) + -- ; traceIf (text "newGlobalBinder" <+> ppr mod <+> ppr occ <+> ppr loc) ; name_supply <- getNameCache ; let (name_supply', name) = allocateGlobalBinder name_supply mod occ diff --git a/ghc/compiler/iface/IfaceSyn.lhs b/ghc/compiler/iface/IfaceSyn.lhs index a53882368f..a15f224c8c 100644 --- a/ghc/compiler/iface/IfaceSyn.lhs +++ b/ghc/compiler/iface/IfaceSyn.lhs @@ -23,7 +23,7 @@ module IfaceSyn ( visibleIfConDecls, -- Converting things to IfaceSyn - tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule, + tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule, -- Equality IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy, @@ -40,10 +40,9 @@ import IfaceType import FunDeps ( pprFundeps ) import NewDemand ( StrictSig, pprIfaceStrictSig ) -import TcType ( deNoteType, tcSplitDFunTy, mkClassPred ) -import Type ( TyThing(..), mkForAllTys, splitForAllTys, funResultTy, - mkPredTy, tidyTopType ) -import InstEnv ( DFunId ) +import TcType ( deNoteType ) +import Type ( TyThing(..), splitForAllTys, funResultTy ) +import InstEnv ( Instance(..), OverlapFlag ) import Id ( Id, idName, idType, idInfo, idArity, isDataConWorkId_maybe, isFCallId_maybe ) import NewDemand ( isTopSig ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), @@ -51,7 +50,7 @@ import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), workerInfo, unfoldingInfo, inlinePragInfo ) import TyCon ( TyCon, ArgVrcs, AlgTyConRhs(..), isRecursiveTyCon, isForeignTyCon, isSynTyCon, isAlgTyCon, isPrimTyCon, isFunTyCon, - isTupleTyCon, tupleTyConBoxity, + isTupleTyCon, tupleTyConBoxity, tyConStupidTheta, tyConHasGenerics, tyConArgVrcs, getSynTyConDefn, tyConArity, tyConTyVars, algTyConRhs, tyConExtName ) import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, @@ -60,7 +59,8 @@ import Class ( FunDep, DefMeth, classExtraBigSig, classTyCon ) import OccName ( OccName, OccEnv, emptyOccEnv, lookupOccEnv, extendOccEnv, parenSymOcc, OccSet, unionOccSets, unitOccSet ) -import Name ( Name, NamedThing(..), nameOccName, isExternalName ) +import Name ( Name, NamedThing(..), nameOccName, isExternalName, + wiredInNameTyThing_maybe ) import NameSet ( NameSet, elemNameSet ) import CostCentre ( CostCentre, pprCostCentreCore ) import Literal ( Literal ) @@ -93,6 +93,7 @@ data IfaceDecl | IfaceData { ifName :: OccName, -- Type constructor ifTyVars :: [IfaceTvBndr], -- Type variables + ifCtxt :: IfaceContext, -- The "stupid theta" ifCons :: IfaceConDecls, -- Includes new/data info ifRec :: RecFlag, -- Recursive or not? ifVrcs :: ArgVrcs, @@ -126,15 +127,13 @@ data IfaceClassOp = IfaceClassOp OccName DefMeth IfaceType data IfaceConDecls = IfAbstractTyCon -- No info - | IfDataTyCon -- data type decls - (Maybe IfaceContext) -- See TyCon.AlgTyConRhs; H98 or GADT - [IfaceConDecl] + | IfDataTyCon [IfaceConDecl] -- data type decls | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] -visibleIfConDecls IfAbstractTyCon = [] -visibleIfConDecls (IfDataTyCon _ cs) = cs -visibleIfConDecls (IfNewTyCon c) = [c] +visibleIfConDecls IfAbstractTyCon = [] +visibleIfConDecls (IfDataTyCon cs) = cs +visibleIfConDecls (IfNewTyCon c) = [c] data IfaceConDecl = IfVanillaCon { @@ -151,9 +150,12 @@ data IfaceConDecl ifConResTys :: [IfaceType], -- Result type args ifConStricts :: [StrictnessMark] } -- Empty (meaning all lazy), or 1-1 corresp with arg types -data IfaceInst = IfaceInst { ifInstHead :: IfaceType, -- Just the instance head type, quantified - -- so that it'll compare alpha-wise - ifDFun :: OccName } -- And the dfun +data IfaceInst + = IfaceInst { ifInstCls :: IfaceExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: OccName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See is_orph in defn of Instance -- There's always a separate IfaceDecl for the DFun, which gives -- its IdInfo with its full type and version number. -- The instance declarations taken together have a version number, @@ -165,13 +167,12 @@ data IfaceRule = IfaceRule { ifRuleName :: RuleName, ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfaceExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfaceExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst } - | IfaceBuiltinRule IfaceExtName CoreRule -- So that built-in rules can - -- wait in the RulePol data IfaceIdInfo = NoInfo -- When writing interface file without -O @@ -207,7 +208,6 @@ data IfaceExpr | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr --- gaw 2004 | IfaceCase IfaceExpr OccName IfaceType [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr @@ -260,18 +260,16 @@ pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, ifSynRhs = mono_ty, i 4 (vcat [equals <+> ppr mono_ty, pprVrcs vrcs]) -pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, +pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, ifTyVars = tyvars, ifCons = condecls, ifRec = isrec, ifVrcs = vrcs}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) 4 (vcat [pprVrcs vrcs, pprRec isrec, pprGen gen, pp_condecls tycon condecls]) where - (context, pp_nd) - = case condecls of - IfAbstractTyCon -> ([], ptext SLIT("data")) - IfDataTyCon Nothing _ -> ([], ptext SLIT("data")) - IfDataTyCon (Just c) _ -> (c, ptext SLIT("data")) - IfNewTyCon _ -> ([], ptext SLIT("newtype")) + pp_nd = case condecls of + IfAbstractTyCon -> ptext SLIT("data") + IfDataTyCon _ -> ptext SLIT("data") + IfNewTyCon _ -> ptext SLIT("newtype") pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, ifFDs = fds, ifSigs = sigs, ifVrcs = vrcs, ifRec = isrec}) @@ -292,9 +290,9 @@ pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), pprIfaceTvBndrs tyvars] -pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") -pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c -pp_condecls tc (IfDataTyCon _ cs) = equals <+> sep (punctuate (ptext SLIT(" |")) +pp_condecls tc IfAbstractTyCon = ptext SLIT("{- abstract -}") +pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c +pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext SLIT(" |")) (map (pprIfaceConDecl tc) cs)) pprIfaceConDecl tc (IfVanillaCon { @@ -322,19 +320,23 @@ pprIfaceConDecl tc (IfGadtCon { -- Gruesome, but jsut for debug print instance Outputable IfaceRule where - ppr (IfaceRule name act bndrs fn args rhs) + ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, ptext SLIT("forall") <+> pprIfaceBndrs bndrs], nest 2 (sep [ppr fn <+> sep (map (pprIfaceExpr parens) args), ptext SLIT("=") <+> ppr rhs]) ] - ppr (IfaceBuiltinRule name rule) - = ptext SLIT("Built-in rule for") <+> ppr name instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifInstHead = ty}) - = hang (ptext SLIT("instance") <+> ppr ty) + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext SLIT("instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_mb mb_tcs)) 2 (equals <+> ppr dfun_id) + where + ppr_mb Nothing = dot + ppr_mb (Just tc) = ppr tc \end{code} @@ -415,9 +417,10 @@ instance Outputable IfaceNote where ppr (IfaceCoreNote s) = ptext SLIT("__core_note") <+> pprHsString (mkFastString s) instance Outputable IfaceConAlt where - ppr IfaceDefault = text "DEFAULT" - ppr (IfaceLitAlt l) = ppr l - ppr (IfaceDataAlt d) = ppr d + ppr IfaceDefault = text "DEFAULT" + ppr (IfaceLitAlt l) = ppr l + ppr (IfaceDataAlt d) = ppr d + ppr (IfaceTupleAlt b) = panic "ppr IfaceConAlt" -- IfaceTupleAlt is handled by the case-alternative printer ------------------ @@ -442,22 +445,21 @@ ppr_hs_info (HsWorker w a) = ptext SLIT("Worker:") <+> ppr w <+> int a \begin{code} -tyThingToIfaceDecl :: Bool - -> NameSet -- Tycons and classes to export abstractly - -> (Name -> IfaceExtName) -> TyThing -> IfaceDecl +tyThingToIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl -- Assumption: the thing is already tidied, so that locally-bound names -- (lambdas, for-alls) already have non-clashing OccNames -- Reason: Iface stuff uses OccNames, and the conversion here does -- not do tidying on the way -tyThingToIfaceDecl discard_id_info _ ext (AnId id) +tyThingToIfaceDecl ext (AnId id) = IfaceId { ifName = getOccName id, ifType = toIfaceType ext (idType id), ifIdInfo = info } where - info | discard_id_info = NoInfo - | otherwise = HasInfo (toIfaceIdInfo ext (idInfo id)) + info = case toIfaceIdInfo ext (idInfo id) of + [] -> NoInfo + items -> HasInfo items -tyThingToIfaceDecl _ _ ext (AClass clas) +tyThingToIfaceDecl ext (AClass clas) = IfaceClass { ifCtxt = toIfaceContext ext sc_theta, ifName = getOccName clas, ifTyVars = toIfaceTvBndrs clas_tyvars, @@ -483,7 +485,7 @@ tyThingToIfaceDecl _ _ ext (AClass clas) toIfaceFD (tvs1, tvs2) = (map getOccName tvs1, map getOccName tvs2) -tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) +tyThingToIfaceDecl ext (ATyCon tycon) | isSynTyCon tycon = IfaceSyn { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, @@ -493,6 +495,7 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) | isAlgTyCon tycon = IfaceData { ifName = getOccName tycon, ifTyVars = toIfaceTvBndrs tyvars, + ifCtxt = toIfaceContext ext (tyConStupidTheta tycon), ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifVrcs = tyConArgVrcs tycon, @@ -504,33 +507,27 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) | isPrimTyCon tycon || isFunTyCon tycon -- Needed in GHCi for ':info Int#', for example - = IfaceData { ifName = getOccName tycon, - ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), - ifCons = IfAbstractTyCon, - ifGeneric = False, - ifRec = NonRecursive, - ifVrcs = tyConArgVrcs tycon } + = IfaceData { ifName = getOccName tycon, + ifTyVars = toIfaceTvBndrs (take (tyConArity tycon) alphaTyVars), + ifCtxt = [], + ifCons = IfAbstractTyCon, + ifGeneric = False, + ifRec = NonRecursive, + ifVrcs = tyConArgVrcs tycon } | otherwise = pprPanic "toIfaceDecl" (ppr tycon) where tyvars = tyConTyVars tycon (_, syn_ty) = getSynTyConDefn tycon - abstract = getName tycon `elemNameSet` abstract_tcs - ifaceConDecls _ | abstract = IfAbstractTyCon - ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) - ifaceConDecls (DataTyCon mb_theta cons _) = IfDataTyCon (ifaceDataCtxt mb_theta) - (map ifaceConDecl cons) + ifaceConDecls (NewTyCon con _ _) = IfNewTyCon (ifaceConDecl con) + ifaceConDecls (DataTyCon cons _) = IfDataTyCon (map ifaceConDecl cons) ifaceConDecls AbstractTyCon = IfAbstractTyCon - -- The last case should never happen when we are generating an - -- interface file (we're exporting this thing, so it's locally defined - -- and should not be abstract). But tyThingToIfaceDecl is also used + -- The last case happens when a TyCon has been trimmed during tidying + -- Furthermore, tyThingToIfaceDecl is also used -- in TcRnDriver for GHCi, when browsing a module, in which case the -- AbstractTyCon case is perfectly sensible. - ifaceDataCtxt Nothing = Nothing - ifaceDataCtxt (Just theta) = Just (toIfaceContext ext theta) - ifaceConDecl data_con | isVanillaDataCon data_con = IfVanillaCon {ifConOcc = getOccName (dataConName data_con), @@ -550,33 +547,26 @@ tyThingToIfaceDecl _ abstract_tcs ext (ATyCon tycon) field_labels = dataConFieldLabels data_con strict_marks = dataConStrictMarks data_con -tyThingToIfaceDecl dis abstr ext (ADataCon dc) - = pprPanic "toIfaceDecl" (ppr dc) +tyThingToIfaceDecl ext (ADataCon dc) + = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier -------------------------- -dfunToIfaceInst :: (Name -> IfaceExtName) -> DFunId -> IfaceInst -dfunToIfaceInst ext_lhs dfun_id - = IfaceInst { ifDFun = nameOccName dfun_name, - ifInstHead = toIfaceType ext_lhs tidy_ty } +instanceToIfaceInst :: (Name -> IfaceExtName) -> Instance -> IfaceInst +instanceToIfaceInst ext_lhs ispec@(Instance { is_dfun = dfun_id, is_flag = oflag, + is_cls = cls, is_tcs = mb_tcs, + is_orph = orph }) + = IfaceInst { ifDFun = getOccName dfun_id, + ifOFlag = oflag, + ifInstCls = ext_lhs cls, + ifInstTys = map do_rough mb_tcs, + ifInstOrph = orph } where - dfun_name = idName dfun_id - (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun_id) - head_ty = mkForAllTys tvs (mkPredTy (mkClassPred cls tys)) - -- No need to record the instance context; - -- it's in the dfun anyway - - tidy_ty = tidyTopType (deNoteType head_ty) - -- The deNoteType is very important. It removes all type - -- synonyms from the instance type in interface files. - -- That in turn makes sure that when reading in instance decls - -- from interface files that the 'gating' mechanism works properly. - -- Otherwise you could have - -- type Tibble = T Int - -- instance Foo Tibble where ... - -- and this instance decl wouldn't get imported into a module - -- that mentioned T but not Tibble. - + do_rough Nothing = Nothing + do_rough (Just n) | Just (ATyCon tc) <- wiredInNameTyThing_maybe n + = Just (toIfaceTyCon ext_lhs tc) + | otherwise + = Just (IfaceTc (ext_lhs n)) -------------------------- toIfaceIdInfo :: (Name -> IfaceExtName) -> IdInfo -> [IfaceInfoItem] @@ -621,20 +611,33 @@ toIfaceIdInfo ext id_info -------------------------- coreRuleToIfaceRule :: (Name -> IfaceExtName) -- For the LHS names -> (Name -> IfaceExtName) -- For the RHS names - -> IdCoreRule -> IfaceRule -coreRuleToIfaceRule ext_lhs ext_rhs (IdCoreRule id _ (BuiltinRule _ _)) - = pprTrace "toHsRule: builtin" (ppr id) (bogusIfaceRule (mkIfaceExtName (getName id))) - -coreRuleToIfaceRule ext_lhs ext_rhs (IdCoreRule id _ (Rule name act bndrs args rhs)) + -> CoreRule -> IfaceRule +coreRuleToIfaceRule ext_lhs ext_rhs (BuiltinRule { ru_fn = fn}) + = pprTrace "toHsRule: builtin" (ppr fn) $ + bogusIfaceRule (mkIfaceExtName fn) + +coreRuleToIfaceRule ext_lhs ext_rhs + (Rule { ru_name = name, ru_fn = fn, ru_act = act, ru_bndrs = bndrs, + ru_args = args, ru_rhs = rhs, ru_orph = orph }) = IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = map (toIfaceBndr ext_lhs) bndrs, - ifRuleHead = ext_lhs (idName id), - ifRuleArgs = map (toIfaceExpr ext_lhs) args, - ifRuleRhs = toIfaceExpr ext_rhs rhs } + ifRuleHead = ext_lhs fn, + ifRuleArgs = map do_arg args, + ifRuleRhs = toIfaceExpr ext_rhs rhs, + ifRuleOrph = orph } + where + -- For type args we must remove synonyms from the outermost + -- level. Reason: so that when we read it back in we'll + -- construct the same ru_rough field as we have right now; + -- see tcIfaceRule + do_arg (Type ty) = IfaceType (toIfaceType ext_lhs (deNoteType ty)) + do_arg arg = toIfaceExpr ext_lhs arg bogusIfaceRule :: IfaceExtName -> IfaceRule bogusIfaceRule id_name - = IfaceRule FSLIT("bogus") NeverActive [] id_name [] (IfaceExt id_name) + = IfaceRule { ifRuleName = FSLIT("bogus"), ifActivation = NeverActive, + ifRuleBndrs = [], ifRuleHead = id_name, ifRuleArgs = [], + ifRuleRhs = IfaceExt id_name, ifRuleOrph = Nothing } --------------------- toIfaceExpr :: (Name -> IfaceExtName) -> CoreExpr -> IfaceExpr @@ -763,7 +766,8 @@ eqIfDecl d1@(IfaceData {}) d2@(IfaceData {}) ifVrcs d1 == ifVrcs d2 && ifGeneric d1 == ifGeneric d2) &&& eqWith (ifTyVars d1) (ifTyVars d2) (\ env -> - eq_hsCD env (ifCons d1) (ifCons d2) + eq_ifContext env (ifCtxt d1) (ifCtxt d2) &&& + eq_hsCD env (ifCons d1) (ifCons d2) ) -- The type variables of the data type do not scope -- over the constructors (any more), but they do scope @@ -792,23 +796,20 @@ eqWith :: [IfaceTvBndr] -> [IfaceTvBndr] -> (EqEnv -> IfaceEq) -> IfaceEq eqWith = eq_ifTvBndrs emptyEqEnv ----------------------- -eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) &&& - zapEq (ifInstHead d1 `eqIfType` ifInstHead d2) - -- zapEq: for instances, ignore the EqBut part +eqIfInst d1 d2 = bool (ifDFun d1 == ifDFun d2) +-- All other changes are handled via the version info on the dfun -eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1) - (IfaceRule n2 a2 bs2 f2 es2 rhs2) - = bool (n1==n2 && a1==a2) &&& +eqIfRule (IfaceRule n1 a1 bs1 f1 es1 rhs1 o1) + (IfaceRule n2 a2 bs2 f2 es2 rhs2 o2) + = bool (n1==n2 && a1==a2 && o1 == o2) &&& f1 `eqIfExt` f2 &&& eq_ifBndrs emptyEqEnv bs1 bs2 (\env -> zapEq (eqListBy (eq_ifaceExpr env) es1 es2) &&& -- zapEq: for the LHSs, ignore the EqBut part eq_ifaceExpr env rhs1 rhs2) -eqIfRule _ _ = NotEqual -eq_hsCD env (IfDataTyCon st1 c1) (IfDataTyCon st2 c2) - = eqMaybeBy (eq_ifContext env) st1 st2 &&& - eqListBy (eq_ConDecl env) c1 c2 +eq_hsCD env (IfDataTyCon c1) (IfDataTyCon c2) + = eqListBy (eq_ConDecl env) c1 c2 eq_hsCD env (IfNewTyCon c1) (IfNewTyCon c2) = eq_ConDecl env c1 c2 eq_hsCD env IfAbstractTyCon IfAbstractTyCon = Equal diff --git a/ghc/compiler/iface/IfaceType.lhs b/ghc/compiler/iface/IfaceType.lhs index 9853a04ea4..e13f77b763 100644 --- a/ghc/compiler/iface/IfaceType.lhs +++ b/ghc/compiler/iface/IfaceType.lhs @@ -14,7 +14,7 @@ module IfaceType ( -- Conversion from Type -> IfaceType toIfaceType, toIfacePred, toIfaceContext, - toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, + toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon, -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, @@ -338,15 +338,15 @@ toIfaceType :: (Name -> IfaceExtName) -> Type -> IfaceType toIfaceType ext (TyVarTy tv) = IfaceTyVar (getOccName tv) toIfaceType ext (AppTy t1 t2) = IfaceAppTy (toIfaceType ext t1) (toIfaceType ext t2) toIfaceType ext (FunTy t1 t2) = IfaceFunTy (toIfaceType ext t1) (toIfaceType ext t2) -toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (mkIfaceTc ext tc) (toIfaceTypes ext tys) +toIfaceType ext (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon ext tc) (toIfaceTypes ext tys) toIfaceType ext (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType ext t) toIfaceType ext (PredTy st) = IfacePredTy (toIfacePred ext st) toIfaceType ext (NoteTy (SynNote tc_app) ty) = toIfaceType ext tc_app -- Retain synonyms toIfaceType ext (NoteTy other_note ty) = toIfaceType ext ty ---------------- -mkIfaceTc :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon -mkIfaceTc ext tc +toIfaceTyCon :: (Name -> IfaceExtName) -> TyCon -> IfaceTyCon +toIfaceTyCon ext tc | isTupleTyCon tc = IfaceTupTc (tupleTyConBoxity tc) (tyConArity tc) | nm == intTyConName = IfaceIntTc | nm == boolTyConName = IfaceBoolTc diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 28c9770fea..9415ac0758 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -8,42 +8,38 @@ module LoadIface ( loadHomeInterface, loadInterface, loadDecls, loadSrcInterface, loadOrphanModules, findAndReadIface, readIface, -- Used when reading the module's old interface - predInstGates, ifaceInstGates, ifaceStats, discardDeclPrags, + ifaceStats, discardDeclPrags, initExternalPackageState ) where #include "HsVersions.h" -import {-# SOURCE #-} TcIface( tcIfaceDecl ) +import {-# SOURCE #-} TcIface( tcIfaceDecl, tcIfaceRule, tcIfaceInst ) import Packages ( PackageState(..), PackageIdH(..), isHomePackage ) import DynFlags ( DynFlags(..), DynFlag( Opt_IgnoreInterfacePragmas ), isOneShot ) import IfaceSyn ( IfaceDecl(..), IfaceConDecl(..), IfaceClassOp(..), - IfaceConDecls(..), IfaceInst(..), IfaceRule(..), - IfaceExpr(..), IfaceTyCon(..), IfaceIdInfo(..), - IfaceType(..), IfacePredType(..), IfaceExtName, - mkIfaceExtName ) -import IfaceEnv ( newGlobalBinder, lookupIfaceExt, lookupIfaceTc, lookupAvail ) + IfaceConDecls(..), IfaceExpr(..), IfaceIdInfo(..), + IfaceType(..), IfaceExtName ) +import IfaceEnv ( newGlobalBinder ) import HscTypes ( ModIface(..), TyThing, emptyModIface, EpsStats(..), addEpsInStats, ExternalPackageState(..), PackageTypeEnv, emptyTypeEnv, HscEnv(..), lookupIfaceByModule, emptyPackageIfaceTable, - IsBootInterface, mkIfaceFixCache, Gated, - implicitTyThings, addRulesToPool, addInstsToPool + IsBootInterface, mkIfaceFixCache, + implicitTyThings ) import BasicTypes ( Version, Fixity(..), FixityDirection(..), isMarkedStrict ) -import TcType ( Type, tcSplitTyConApp_maybe ) -import Type ( funTyCon ) import TcRnMonad import PrelNames ( gHC_PRIM ) import PrelInfo ( ghcPrimExports ) import PrelRules ( builtinRules ) -import Rules ( emptyRuleBase ) -import InstEnv ( emptyInstEnv ) +import Rules ( extendRuleBaseList, mkRuleBase ) +import InstEnv ( emptyInstEnv, extendInstEnvList ) import Name ( Name {-instance NamedThing-}, getOccName, nameModule, isInternalName ) import NameEnv @@ -54,10 +50,8 @@ import Module ( Module, ModLocation(ml_hi_file), emptyModuleEnv, ) import OccName ( OccName, mkOccEnv, lookupOccEnv, mkClassTyConOcc, mkClassDataConOcc, mkSuperDictSelOcc, mkDataConWrapperOcc, mkDataConWorkerOcc ) -import Class ( Class, className ) -import TyCon ( tyConName ) import SrcLoc ( importedSrcLoc ) -import Maybes ( mapCatMaybes, MaybeErr(..) ) +import Maybes ( MaybeErr(..) ) import FastString ( mkFastString ) import ErrUtils ( Message ) import Finder ( findModule, findPackageModule, FindResult(..), cantFindError ) @@ -65,16 +59,14 @@ import Outputable import BinIface ( readBinIface ) import Panic ( ghcError, tryMost, showException, GhcException(..) ) import List ( nub ) - -import DATA_IOREF ( readIORef ) \end{code} %************************************************************************ %* * - loadSrcInterface, loadOrphanModules + loadSrcInterface, loadOrphanModules, loadHomeInterface - These two are called from TcM-land + These three are called from TcM-land %* * %************************************************************************ @@ -94,6 +86,7 @@ loadSrcInterface doc mod want_boot elaborate err = hang (ptext SLIT("Failed to load interface for") <+> quotes (ppr mod) <> colon) 4 err +--------------- loadOrphanModules :: [Module] -> TcM () loadOrphanModules mods | null mods = returnM () @@ -105,21 +98,14 @@ loadOrphanModules mods where load mod = loadSysInterface (mk_doc mod) mod mk_doc mod = ppr mod <+> ptext SLIT("is a orphan-instance module") -\end{code} - -%********************************************************* -%* * - loadHomeInterface - Called from Iface-land -%* * -%********************************************************* -\begin{code} -loadHomeInterface :: SDoc -> Name -> IfM lcl ModIface +--------------- +loadHomeInterface :: SDoc -> Name -> TcRn ModIface loadHomeInterface doc name = ASSERT2( not (isInternalName name), ppr name <+> parens doc ) - loadSysInterface doc (nameModule name) + initIfaceTcRn $ loadSysInterface doc (nameModule name) +--------------- loadSysInterface :: SDoc -> Module -> IfM lcl ModIface -- A wrapper for loadInterface that Throws an exception if it fails loadSysInterface doc mod_name @@ -143,6 +129,7 @@ loadSysInterface doc mod_name \begin{code} loadInterface :: SDoc -> Module -> WhereFrom -> IfM lcl (MaybeErr Message ModIface) + -- If it can't find a suitable interface file, we -- a) modify the PackageIfaceTable to have an empty entry -- (to avoid repeated complaints) @@ -226,22 +213,22 @@ loadInterface doc_str mod from ; ignore_prags <- doptM Opt_IgnoreInterfacePragmas ; new_eps_decls <- loadDecls ignore_prags (mi_decls iface) - ; new_eps_insts <- mapM loadInst (mi_insts iface) + ; new_eps_insts <- mapM tcIfaceInst (mi_insts iface) ; new_eps_rules <- if ignore_prags then return [] - else mapM loadRule (mi_rules iface) + else mapM tcIfaceRule (mi_rules iface) ; let { final_iface = iface { mi_decls = panic "No mi_decls in PIT", mi_insts = panic "No mi_insts in PIT", mi_rules = panic "No mi_rules in PIT" } } ; updateEps_ $ \ eps -> - eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, - eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, - eps_rules = addRulesToPool (eps_rules eps) new_eps_rules, - eps_insts = addInstsToPool (eps_insts eps) new_eps_insts, - eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) - (length new_eps_insts) (length new_eps_rules) } + eps { eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface, + eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls, + eps_rule_base = extendRuleBaseList (eps_rule_base eps) new_eps_rules, + eps_inst_env = extendInstEnvList (eps_inst_env eps) new_eps_insts, + eps_stats = addEpsInStats (eps_stats eps) (length new_eps_decls) + (length new_eps_insts) (length new_eps_rules) } ; return (Succeeded final_iface) }}}} @@ -352,7 +339,7 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfNewTyCon (IfVanillaCon { ifConOcc = con = fields ++ [con_occ, mkDataConWrapperOcc con_occ] -- Wrapper, no worker; see MkId.mkDataConIds -ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) +ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon cons}) = nub (concatMap fld_occs cons) -- Eliminate duplicate fields ++ concatMap dc_occs cons where @@ -371,136 +358,6 @@ ifaceDeclSubBndrs (IfaceData {ifCons = IfDataTyCon _ cons}) ifaceDeclSubBndrs _other = [] ------------------------------------------------------ --- Loading instance decls ------------------------------------------------------ - -loadInst :: IfaceInst -> IfL (Name, Gated IfaceInst) - -loadInst decl@(IfaceInst {ifInstHead = inst_ty}) - = do { - -- Find out what type constructors and classes are "gates" for the - -- instance declaration. If all these "gates" are slurped in then - -- we should slurp the instance decl too. - -- - -- We *don't* want to count names in the context part as gates, though. - -- For example: - -- instance Foo a => Baz (T a) where ... - -- - -- Here the gates are Baz and T, but *not* Foo. - -- - -- HOWEVER: functional dependencies make things more complicated - -- class C a b | a->b where ... - -- instance C Foo Baz where ... - -- Here, the gates are really only C and Foo, *not* Baz. - -- That is, if C and Foo are visible, even if Baz isn't, we must - -- slurp the decl. - -- - -- Rather than take fundeps into account "properly", we just slurp - -- if C is visible and *any one* of the Names in the types - -- This is a slightly brutal approximation, but most instance decls - -- are regular H98 ones and it's perfect for them. - -- - -- NOTICE that we rename the type before extracting its free - -- variables. The free-variable finder for a renamed HsType - -- does the Right Thing for built-in syntax like [] and (,). - let { (cls_ext, tc_exts) = ifaceInstGates inst_ty } - ; cls <- lookupIfaceExt cls_ext - ; tcs <- mapM lookupIfaceTc tc_exts - ; (mod, doc) <- getIfCtxt - ; returnM (cls, (tcs, (mod, doc, decl))) - } - ------------------------------------------------------ --- Loading Rules ------------------------------------------------------ - -loadRule :: IfaceRule -> IfL (Gated IfaceRule) --- "Gate" the rule simply by a crude notion of the free vars of --- the LHS. It can be crude, because having too few free vars is safe. -loadRule decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args}) - = do { names <- mapM lookupIfaceExt (fn : arg_fvs) - ; (mod, doc) <- getIfCtxt - ; returnM (names, (mod, doc, decl)) } - where - arg_fvs = [n | arg <- args, n <- crudeIfExprGblFvs arg] - - ---------------------------- -crudeIfExprGblFvs :: IfaceExpr -> [IfaceExtName] --- A crude approximation to the free external names of an IfExpr --- Returns a subset of the true answer -crudeIfExprGblFvs (IfaceType ty) = get_tcs ty -crudeIfExprGblFvs (IfaceExt v) = [v] -crudeIfExprGblFvs other = [] -- Well, I said it was crude - -get_tcs :: IfaceType -> [IfaceExtName] --- Get a crude subset of the TyCons of an IfaceType -get_tcs (IfaceTyVar _) = [] -get_tcs (IfaceAppTy t1 t2) = get_tcs t1 ++ get_tcs t2 -get_tcs (IfaceFunTy t1 t2) = get_tcs t1 ++ get_tcs t2 -get_tcs (IfaceForAllTy _ t) = get_tcs t -get_tcs (IfacePredTy st) = case st of - IfaceClassP cl ts -> get_tcs_s ts - IfaceIParam _ t -> get_tcs t -get_tcs (IfaceTyConApp (IfaceTc tc) ts) = tc : get_tcs_s ts -get_tcs (IfaceTyConApp other ts) = get_tcs_s ts - --- The lists are always small => appending is fine -get_tcs_s :: [IfaceType] -> [IfaceExtName] -get_tcs_s tys = foldr ((++) . get_tcs) [] tys - - ----------------- -getIfCtxt :: IfL (Module, SDoc) -getIfCtxt = do { env <- getLclEnv; return (if_mod env, if_loc env) } -\end{code} - - -%********************************************************* -%* * - Gating -%* * -%********************************************************* - -Extract the gates of an instance declaration - -\begin{code} -ifaceInstGates :: IfaceType -> (IfaceExtName, [IfaceTyCon]) --- Return the class, and the tycons mentioned in the rest of the head --- We only pick the TyCon at the root of each type, to avoid --- difficulties with overlap. For example, suppose there are interfaces --- in the pool for --- C Int b --- C a [b] --- C a [T] --- Then, if we are trying to resolve (C Int x), we need the first --- if we are trying to resolve (C x [y]), we need *both* the latter --- two, even though T is not involved yet, so that we spot the overlap - -ifaceInstGates (IfaceForAllTy _ t) = ifaceInstGates t -ifaceInstGates (IfaceFunTy _ t) = ifaceInstGates t -ifaceInstGates (IfacePredTy (IfaceClassP cls tys)) = (cls, instHeadTyconGates tys) -ifaceInstGates other = pprPanic "ifaceInstGates" (ppr other) - -- The other cases should not happen - -instHeadTyconGates tys = mapCatMaybes root_tycon tys - where - root_tycon (IfaceFunTy _ _) = Just (IfaceTc funTyConExtName) - root_tycon (IfaceTyConApp tc _) = Just tc - root_tycon other = Nothing - -funTyConExtName = mkIfaceExtName (tyConName funTyCon) - - -predInstGates :: Class -> [Type] -> (Name, [Name]) --- The same function, only this time on the predicate found in a dictionary -predInstGates cls tys - = (className cls, mapCatMaybes root_tycon tys) - where - root_tycon ty = case tcSplitTyConApp_maybe ty of - Just (tc, _) -> Just (tyConName tc) - Nothing -> Nothing \end{code} @@ -625,18 +482,12 @@ initExternalPackageState eps_PIT = emptyPackageIfaceTable, eps_PTE = emptyTypeEnv, eps_inst_env = emptyInstEnv, - eps_rule_base = emptyRuleBase, - eps_insts = emptyNameEnv, - eps_rules = addRulesToPool [] (map mk_gated_rule builtinRules), + eps_rule_base = mkRuleBase builtinRules, -- Initialise the EPS rule pool with the built-in rules eps_stats = EpsStats { n_ifaces_in = 0, n_decls_in = 0, n_decls_out = 0 , n_insts_in = 0, n_insts_out = 0 , n_rules_in = length builtinRules, n_rules_out = 0 } } - where - mk_gated_rule (fn_name, core_rule) - = ([fn_name], (nameModule fn_name, ptext SLIT("<built-in rule>"), - IfaceBuiltinRule (mkIfaceExtName fn_name) core_rule)) \end{code} diff --git a/ghc/compiler/iface/MkIface.lhs b/ghc/compiler/iface/MkIface.lhs index ada3671fc8..b5abe7ee20 100644 --- a/ghc/compiler/iface/MkIface.lhs +++ b/ghc/compiler/iface/MkIface.lhs @@ -11,6 +11,8 @@ module MkIface ( mkIface, -- Build a ModIface from a ModGuts, -- including computing version information + writeIfaceFile, -- Write the interface file + checkOldIface -- See if recompilation is required, by -- comparing version information ) where @@ -176,16 +178,15 @@ compiled with -O. I think this is the case.] import HsSyn import Packages ( isHomeModule, PackageIdH(..) ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), - IfaceRule(..), IfaceInst(..), IfaceExtName(..), IfaceTyCon(..), + IfaceRule(..), IfaceInst(..), IfaceExtName(..), eqIfDecl, eqIfRule, eqIfInst, IfaceEq(..), (&&&), bool, eqMaybeBy, eqListBy, visibleIfConDecls, - tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule ) -import LoadIface ( readIface, loadInterface, ifaceInstGates ) + tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule ) +import LoadIface ( readIface, loadInterface ) import BasicTypes ( Version, initialVersion, bumpVersion ) import TcRnMonad import TcRnTypes ( mkModDeps ) -import TcType ( isFFITy ) -import HscTypes ( ModIface(..), TyThing(..), +import HscTypes ( ModIface(..), ModGuts(..), ModGuts, IfaceExport, HscEnv(..), hscEPS, Dependencies(..), FixItem(..), ModSummary(..), msHiFilePath, @@ -202,8 +203,8 @@ import HscTypes ( ModIface(..), TyThing(..), import DynFlags ( GhcMode(..), DynFlags(..), DynFlag(..), dopt ) import StaticFlags ( opt_HiVersion ) import Name ( Name, nameModule, nameOccName, nameParent, - isExternalName, nameParent_maybe, isWiredInName, - NamedThing(..) ) + isExternalName, isInternalName, nameParent_maybe, isWiredInName, + isImplicitName, NamedThing(..) ) import NameEnv import NameSet import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, @@ -212,9 +213,6 @@ import OccName ( OccName, OccEnv, mkOccEnv, lookupOccEnv, emptyOccEnv, extendOccSet, extendOccSetList, isEmptyOccSet, intersectOccSet, intersectsOccSet, occNameFS, isTcOcc ) -import TyCon ( tyConDataCons, isNewTyCon, newTyConRep ) -import Class ( classSelIds ) -import DataCon ( dataConName, dataConFieldLabels ) import Module ( Module, moduleFS, ModLocation(..), mkSysModuleFS, moduleUserString, ModuleEnv, emptyModuleEnv, lookupModuleEnv, @@ -249,52 +247,42 @@ import Maybes ( orElse, mapCatMaybes, isNothing, isJust, \begin{code} mkIface :: HscEnv - -> ModLocation -> Maybe ModIface -- The old interface, if we have it -> ModGuts -- The compiled, tidied module - -> IO ModIface -- The new one, complete with decls and versions --- mkIface --- a) Builds the ModIface --- b) Writes it out to a file if necessary - -mkIface hsc_env location maybe_old_iface - guts@ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_usages = usages, - mg_deps = deps, + -> IO (ModIface, -- The new one, complete with decls and versions + Bool) -- True <=> there was an old Iface, and the new one + -- is identical, so no need to write it + +mkIface hsc_env maybe_old_iface + guts@ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_usages = usages, + mg_deps = deps, mg_exports = exports, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_deprecs = src_deprecs, - mg_insts = insts, - mg_rules = rules, - mg_types = type_env } + mg_insts = insts, + mg_rules = rules, + mg_types = type_env } +-- NB: notice that mkIface does not look at the bindings +-- only at the TypeEnv. The previous Tidy phase has +-- put exactly the info into the TypeEnv that we want +-- to expose in the interface + = do { eps <- hscEPS hsc_env ; let { ext_nm_rhs = mkExtNameFn hsc_env eps this_mod ; ext_nm_lhs = mkLhsNameFn this_mod - ; local_things = [thing | thing <- typeEnvElts type_env, - not (isWiredInName (getName thing)) ] - -- Do not export anything about wired-in things - -- (GHC knows about them already) - - ; abstract_tcs :: NameSet -- TyCons and Classes whose representation is not exposed - ; abstract_tcs - | not omit_prags = emptyNameSet -- In the -O case, nothing is abstract - | otherwise = mkNameSet [ getName thing - | thing <- local_things - , not (mustExposeThing exports thing)] - - ; decls = [ tyThingToIfaceDecl omit_prags abstract_tcs ext_nm_rhs thing - | thing <- local_things, wantDeclFor exports abstract_tcs thing ] - -- Don't put implicit Ids and class tycons in the interface file - - ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] - ; deprecs = mkIfaceDeprec src_deprecs - ; iface_rules - | omit_prags = [] - | otherwise = sortLe le_rule $ - map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules - ; iface_insts = sortLe le_inst (map (dfunToIfaceInst ext_nm_lhs) insts) + + ; decls = [ tyThingToIfaceDecl ext_nm_rhs thing + | thing <- typeEnvElts type_env, + not (isImplicitName (getName thing)) ] + -- Don't put implicit Ids and class tycons in the interface file + + ; fixities = [(occ,fix) | FixItem occ fix _ <- nameEnvElts fix_env] + ; deprecs = mkIfaceDeprec src_deprecs + ; iface_rules = map (coreRuleToIfaceRule ext_nm_lhs ext_nm_rhs) rules + ; iface_insts = map (instanceToIfaceInst ext_nm_lhs) insts ; intermediate_iface = ModIface { mi_module = this_mod, @@ -303,8 +291,8 @@ mkIface hsc_env location maybe_old_iface mi_deps = deps, mi_usages = usages, mi_exports = mkIfaceExports exports, - mi_insts = iface_insts, - mi_rules = iface_rules, + mi_insts = sortLe le_inst iface_insts, + mi_rules = sortLe le_rule iface_rules, mi_fixities = fixities, mi_deprecs = deprecs, mi_globals = Just rdr_env, @@ -328,11 +316,6 @@ mkIface hsc_env location maybe_old_iface addVersionInfo maybe_old_iface intermediate_iface decls } - -- Write the interface file, if necessary - ; when (not no_change_at_all && ghci_mode /= Interactive) $ do - createDirectoryHierarchy (directoryOf hi_file_path) - writeBinIface hi_file_path new_iface - -- Debug printing ; when (isJust pp_orphs && dopt Opt_WarnOrphans dflags) (printDump (fromJust pp_orphs)) @@ -340,56 +323,28 @@ mkIface hsc_env location maybe_old_iface ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) - ; return new_iface } + ; return (new_iface, no_change_at_all) } where r1 `le_rule` r2 = ifRuleName r1 <= ifRuleName r2 i1 `le_inst` i2 = ifDFun i1 <= ifDFun i2 - dflags = hsc_dflags hsc_env - ghci_mode = ghcMode (hsc_dflags hsc_env) - omit_prags = dopt Opt_OmitInterfacePragmas dflags - hi_file_path = ml_hi_file location + dflags = hsc_dflags hsc_env + deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) -mustExposeThing :: NameSet -> TyThing -> Bool --- We are compiling without -O, and thus trying to write as little as --- possible into the interface file. But we must expose the details of --- any data types and classes whose constructors, fields, methods are --- visible to an importing module -mustExposeThing exports (ATyCon tc) - = any exported_data_con (tyConDataCons tc) - -- Expose rep if any datacon or field is exported - - || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) - -- Expose the rep for newtypes if the rep is an FFI type. - -- For a very annoying reason. 'Foreign import' is meant to - -- be able to look through newtypes transparently, but it - -- can only do that if it can "see" the newtype representation - where - exported_data_con con - = any (`elemNameSet` exports) (dataConName con : dataConFieldLabels con) - -mustExposeThing exports (AClass cls) - = any exported_class_op (classSelIds cls) - where -- Expose rep if any classs op is exported - exported_class_op op = getName op `elemNameSet` exports - -mustExposeThing exports other = False - - -wantDeclFor :: NameSet -- User-exported things - -> NameSet -- Abstract things - -> TyThing -> Bool -wantDeclFor exports abstracts thing - | Just parent <- nameParent_maybe name -- An implicit thing - = parent `elemNameSet` abstracts && name `elemNameSet` exports +----------------------------- +writeIfaceFile :: HscEnv -> ModLocation -> ModIface -> Bool -> IO () +-- Write the interface file, if necessary +writeIfaceFile hsc_env location new_iface no_change_at_all + | no_change_at_all = return () + | ghc_mode == Interactive = return () | otherwise - = True + = do { createDirectoryHierarchy (directoryOf hi_file_path) + ; writeBinIface hi_file_path new_iface } where - name = getName thing - + ghc_mode = ghcMode (hsc_dflags hsc_env) + hi_file_path = ml_hi_file location -deliberatelyOmitted x = panic ("Deliberately omitted: " ++ x) ----------------------------- mkExtNameFn :: HscEnv -> ExternalPackageState -> Module -> Name -> IfaceExtName @@ -431,6 +386,8 @@ mkExtNameFn hsc_env eps this_mod -- there's no point in recording version info mkLhsNameFn :: Module -> Name -> IfaceExtName mkLhsNameFn this_mod name + | isInternalName name = pprTrace "mkLhsNameFn: unexpected internal" (ppr name) $ + LocalTop occ -- Should not happen | mod == this_mod = LocalTop occ | otherwise = ExtPkg mod occ where @@ -451,16 +408,16 @@ addVersionInfo :: Maybe ModIface -- The old interface, read from M.hi addVersionInfo Nothing new_iface new_decls -- No old interface, so definitely write a new one! - = (new_iface { mi_orphan = anyNothing getInstKey (mi_insts new_iface) - || anyNothing getRuleKey (mi_rules new_iface), + = (new_iface { mi_orphan = anyNothing ifInstOrph (mi_insts new_iface) + || anyNothing ifRuleOrph (mi_rules new_iface), mi_decls = [(initialVersion, decl) | decl <- new_decls], mi_ver_fn = \n -> Just initialVersion }, False, ptext SLIT("No old interface file"), pprOrphans orph_insts orph_rules) where - orph_insts = filter (isNothing . getInstKey) (mi_insts new_iface) - orph_rules = filter (isNothing . getRuleKey) (mi_rules new_iface) + orph_insts = filter (isNothing . ifInstOrph) (mi_insts new_iface) + orph_rules = filter (isNothing . ifRuleOrph) (mi_rules new_iface) addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, mi_exp_vers = old_exp_vers, @@ -485,14 +442,14 @@ addVersionInfo (Just old_iface@(ModIface { mi_mod_vers = old_mod_vers, decls_w_vers = [(add_vers decl, decl) | decl <- new_decls] ------------------- - (old_non_orph_insts, old_orph_insts) = mkRuleMap getInstKey (mi_insts old_iface) - (new_non_orph_insts, new_orph_insts) = mkRuleMap getInstKey (mi_insts new_iface) + (old_non_orph_insts, old_orph_insts) = mkOrphMap ifInstOrph (mi_insts old_iface) + (new_non_orph_insts, new_orph_insts) = mkOrphMap ifInstOrph (mi_insts new_iface) same_insts occ = eqMaybeBy (eqListBy eqIfInst) (lookupOccEnv old_non_orph_insts occ) (lookupOccEnv new_non_orph_insts occ) - (old_non_orph_rules, old_orph_rules) = mkRuleMap getRuleKey (mi_rules old_iface) - (new_non_orph_rules, new_orph_rules) = mkRuleMap getRuleKey (mi_rules new_iface) + (old_non_orph_rules, old_orph_rules) = mkOrphMap ifRuleOrph (mi_rules old_iface) + (new_non_orph_rules, new_orph_rules) = mkOrphMap ifRuleOrph (mi_rules new_iface) same_rules occ = eqMaybeBy (eqListBy eqIfRule) (lookupOccEnv old_non_orph_rules occ) (lookupOccEnv new_non_orph_rules occ) @@ -635,17 +592,17 @@ changedWrt so_far NotEqual = True changedWrt so_far (EqBut kids) = so_far `intersectsOccSet` kids ---------------------- --- mkRuleMap partitions instance decls or rules into +-- mkOrphMap partitions instance decls or rules into -- (a) an OccEnv for ones that are not orphans, -- mapping the local OccName to a list of its decls -- (b) a list of orphan decls -mkRuleMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ +mkOrphMap :: (decl -> Maybe OccName) -- (Just occ) for a non-orphan decl, keyed by occ -- Nothing for an orphan decl -> [decl] -- Sorted into canonical order -> (OccEnv [decl], -- Non-orphan decls associated with their key; -- each sublist in canonical order [decl]) -- Orphan decls; in canonical order -mkRuleMap get_key decls +mkOrphMap get_key decls = foldl go (emptyOccEnv, []) decls where go (non_orphs, orphs) d @@ -653,22 +610,6 @@ mkRuleMap get_key decls = (extendOccEnv_C (\ ds _ -> d:ds) non_orphs occ [d], orphs) | otherwise = (non_orphs, d:orphs) --- getXxKey: find at least one local OccName that belongs to this decl - -getInstKey :: IfaceInst -> Maybe OccName -getInstKey (IfaceInst {ifInstHead = inst_ty}) - = case [occ | LocalTop occ <- cls_ext : tc_exts] of - [] -> Nothing - (occ:_) -> Just occ - where - (cls_ext, tcs) = ifaceInstGates inst_ty - tc_exts = [tc | IfaceTc tc <- tcs] - -- Ignore the wired-in IfaceTyCons; the class will do as the key - -getRuleKey :: IfaceRule -> Maybe OccName -getRuleKey (IfaceRule {ifRuleHead = LocalTop occ}) = Just occ -getRuleKey other = Nothing - anyNothing :: (a -> Maybe b) -> [a] -> Bool anyNothing p [] = False anyNothing p (x:xs) = isNothing (p x) || anyNothing p xs diff --git a/ghc/compiler/iface/TcIface.hi-boot-6 b/ghc/compiler/iface/TcIface.hi-boot-6 index 7ad3511c98..b03830c03d 100644 --- a/ghc/compiler/iface/TcIface.hi-boot-6 +++ b/ghc/compiler/iface/TcIface.hi-boot-6 @@ -1,4 +1,7 @@ module TcIface where tcIfaceDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL TypeRep.TyThing +tcIfaceInst :: IfaceSyn.IfaceInst -> TcRnTypes.IfL InstEnv.Instance +tcIfaceRule :: IfaceSyn.IfaceRule -> TcRnTypes.IfL CoreSyn.CoreRule + diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 685d0be069..f7b9ca0b6c 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -5,43 +5,38 @@ \begin{code} module TcIface ( - tcImportDecl, tcHiBootIface, typecheckIface, - tcIfaceDecl, tcIfaceGlobal, - loadImportedInsts, loadImportedRules, + tcImportDecl, checkWiredInTyCon, tcHiBootIface, typecheckIface, + tcIfaceDecl, tcIfaceInst, tcIfaceRule, tcIfaceGlobal, tcExtCoreBindings ) where #include "HsVersions.h" import IfaceSyn -import LoadIface ( loadHomeInterface, loadInterface, predInstGates, - loadDecls, findAndReadIface ) +import LoadIface ( loadInterface, loadHomeInterface, loadDecls, findAndReadIface ) import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName, - tcIfaceTyVar, tcIfaceLclId, + tcIfaceTyVar, tcIfaceLclId, lookupIfaceTc, newIfaceName, newIfaceNames, ifaceExportNames ) import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass, mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs ) import TcRnMonad import TcType ( hoistForAllTys ) -- TEMPORARY HACK import Type ( liftedTypeKind, splitTyConApp, mkSynTy, mkTyConApp, - mkTyVarTys, mkGenTyConApp, ThetaType, pprClassPred ) + mkTyVarTys, ThetaType, + mkGenTyConApp ) -- Don't remove this... see mkIfTcApp import TypeRep ( Type(..), PredType(..) ) import TyCon ( TyCon, tyConName, isSynTyCon ) -import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv, - HscEnv, TyThing(..), tyThingClass, tyThingTyCon, - ModIface(..), ModDetails(..), ModGuts, HomeModInfo(..), - emptyModDetails, - extendTypeEnv, lookupTypeEnv, lookupType, typeEnvIds ) -import InstEnv ( extendInstEnvList ) +import HscTypes ( ExternalPackageState(..), + TyThing(..), tyThingClass, tyThingTyCon, + ModIface(..), ModDetails(..), HomeModInfo(..), + emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds ) +import InstEnv ( Instance(..), mkImportedInstance ) import CoreSyn -import PprCore ( pprIdRules ) -import Rules ( extendRuleBaseList ) import CoreUtils ( exprType ) import CoreUnfold import CoreLint ( lintUnfolding ) import WorkWrap ( mkWrapper ) -import InstEnv ( DFunId ) import Id ( Id, mkVanillaGlobal, mkLocalId ) import MkId ( mkFCallId ) import IdInfo ( IdInfo, CafInfo(..), WorkerInfo(..), @@ -53,8 +48,8 @@ import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon ) import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon ) import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon ) import Var ( TyVar, mkTyVar, tyVarKind ) -import Name ( Name, nameModule, nameIsLocalOrFrom, - isWiredInName, wiredInNameTyThing_maybe, nameParent ) +import Name ( Name, nameModule, nameIsLocalOrFrom, isWiredInName, + wiredInNameTyThing_maybe, nameParent ) import NameEnv import OccName ( OccName ) import Module ( Module, lookupModuleEnv ) @@ -112,28 +107,49 @@ also turn out to be needed by the code that e2 expands to. \begin{code} tcImportDecl :: Name -> TcM TyThing --- Entry point for source-code uses of importDecl +-- Entry point for *source-code* uses of importDecl tcImportDecl name + | Just thing <- wiredInNameTyThing_maybe name + = do { checkWiredInName name; return thing } + | otherwise = do { traceIf (text "tcLookupGlobal" <+> ppr name) ; mb_thing <- initIfaceTcRn (importDecl name) ; case mb_thing of Succeeded thing -> return thing Failed err -> failWithTc err } +checkWiredInTyCon :: TyCon -> TcM () +-- Ensure its instances are loaded +-- It might not be a wired-in tycon (see the calls in TcUnify) +checkWiredInTyCon tc + | not (isWiredInName tc_name) = return () + | otherwise = checkWiredInName tc_name + where + tc_name = tyConName tc + +checkWiredInName :: Name -> TcM () +-- We "check" a wired-in name solely to check that its +-- interface file is loaded, so that we're sure that we see +-- its instance declarations and rules +checkWiredInName name + = ASSERT( isWiredInName name ) + do { mod <- getModule + ; if nameIsLocalOrFrom mod name then + -- Don't look for (non-existent) Float.hi when + -- compiling Float.lhs, which mentions Float of course + return () + else -- A bit yukky to call initIfaceTcRn here + do { loadHomeInterface doc name; return () } + } + where + doc = ptext SLIT("Need home interface for wired-in thing") <+> ppr name + importDecl :: Name -> IfM lcl (MaybeErr Message TyThing) -- Get the TyThing for this Name from an interface file -importDecl name - | Just thing <- wiredInNameTyThing_maybe name - -- This case definitely happens for tuples, because we - -- don't know how many of them we'll find - -- It also now happens for all other wired in things. We used - -- to pre-populate the eps_PTE with other wired-in things, but - -- we don't seem to do that any more. I guess it keeps the PTE smaller? - = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing }) - ; return (Succeeded thing) } - - | otherwise - = do { traceIf nd_doc +-- It's not a wired-in thing -- the caller caught that +importDecl name + = ASSERT( not (isWiredInName name) ) + do { traceIf nd_doc -- Load the interface, which should populate the PTE ; mb_iface <- loadInterface nd_doc (nameModule name) ImportBySystem @@ -328,6 +344,7 @@ tcIfaceDecl (IfaceId {ifName = occ_name, ifType = iface_type, ifIdInfo = info}) tcIfaceDecl (IfaceData {ifName = occ_name, ifTyVars = tv_bndrs, + ifCtxt = ctxt, ifCons = rdr_cons, ifVrcs = arg_vrcs, ifRec = is_rec, ifGeneric = want_generic }) @@ -335,10 +352,10 @@ tcIfaceDecl (IfaceData {ifName = occ_name, ; bindIfaceTyVars tv_bndrs $ \ tyvars -> do { tycon <- fixM ( \ tycon -> do - { cons <- tcIfaceDataCons tycon tyvars rdr_cons - ; tycon <- buildAlgTyCon tc_name tyvars cons - arg_vrcs is_rec want_generic - ; return tycon + { stupid_theta <- tcIfaceCtxt ctxt + ; cons <- tcIfaceDataCons tycon tyvars rdr_cons + ; buildAlgTyCon tc_name tyvars stupid_theta + cons arg_vrcs is_rec want_generic }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) @@ -384,16 +401,12 @@ tcIfaceDecl (IfaceForeign {ifName = rdr_name, ifExtName = ext_name}) tcIfaceDataCons tycon tc_tyvars if_cons = case if_cons of - IfAbstractTyCon -> return mkAbstractTyConRhs - IfDataTyCon mb_ctxt cons -> do { mb_theta <- tc_ctxt mb_ctxt - ; data_cons <- mappM tc_con_decl cons - ; return (mkDataTyConRhs mb_theta data_cons) } - IfNewTyCon con -> do { data_con <- tc_con_decl con - ; return (mkNewTyConRhs tycon data_con) } + IfAbstractTyCon -> return mkAbstractTyConRhs + IfDataTyCon cons -> do { data_cons <- mappM tc_con_decl cons + ; return (mkDataTyConRhs data_cons) } + IfNewTyCon con -> do { data_con <- tc_con_decl con + ; return (mkNewTyConRhs tycon data_con) } where - tc_ctxt Nothing = return Nothing - tc_ctxt (Just ctxt) = do { theta <- tcIfaceCtxt ctxt; return (Just theta) } - tc_con_decl (IfVanillaCon { ifConOcc = occ, ifConInfix = is_infix, ifConArgTys = args, ifConStricts = stricts, ifConFields = field_lbls}) = do { name <- lookupIfaceTop occ @@ -443,118 +456,22 @@ tcIfaceDataCons tycon tc_tyvars if_cons %* * %************************************************************************ -The gating story for instance declarations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -When we are looking for a dict (C t1..tn), we slurp in instance decls for -C that - mention at least one of the type constructors - at the roots of t1..tn - -Why "at least one" rather than "all"? Because functional dependencies -complicate the picture. Consider - class C a b | a->b where ... - instance C Foo Baz where ... -Here, the gates are really only C and Foo, *not* Baz. -That is, if C and Foo are visible, even if Baz isn't, we must -slurp the decl, even if Baz is thus far completely unknown to the -system. - -Why "roots of the types"? Reason is overlap. For example, suppose there -are interfaces in the pool for - (a) C Int b - (b) C a [b] - (c) C a [T] -Then, if we are trying to resolve (C Int x), we need (a) -if we are trying to resolve (C x [y]), we need *both* (b) and (c), -even though T is not involved yet, so that we spot the overlap. - - -NOTE: if you use an instance decl with NO type constructors - instance C a where ... -and look up an Inst that only has type variables such as (C (n o)) -then GHC won't necessarily suck in the instances that overlap with this. - - \begin{code} -loadImportedInsts :: Class -> [Type] -> TcM PackageInstEnv -loadImportedInsts cls tys - = do { -- Get interfaces for wired-in things, such as Integer - -- Any non-wired-in tycons will already be loaded, else - -- we couldn't have them in the Type - ; this_mod <- getModule - ; let { (cls_gate, tc_gates) = predInstGates cls tys - ; imp_wi n = isWiredInName n && this_mod /= nameModule n - ; wired_tcs = filter imp_wi tc_gates } - -- Wired-in tycons not from this module. The "this-module" - -- test bites only when compiling Base etc, because loadHomeInterface - -- barfs if it's asked to load a non-existent interface - ; if null wired_tcs then returnM () - else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs) - - -- Now suck in the relevant instances - ; iface_insts <- updateEps (selectInsts cls_gate tc_gates) - - -- Empty => finish up rapidly, without writing to eps - ; if null iface_insts then - do { eps <- getEps; return (eps_inst_env eps) } - else do - { traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys, - nest 2 (vcat [ppr i | (_,_,i) <- iface_insts])]) - - -- Typecheck the new instances - ; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts) - - -- And put them in the package instance environment - ; updateEps ( \ eps -> - let - inst_env' = extendInstEnvList (eps_inst_env eps) dfuns - in - (eps { eps_inst_env = inst_env' }, inst_env') - )}} - where - wired_doc = ptext SLIT("Need home inteface for wired-in thing") - -tc_inst (mod, loc, inst) = initIfaceLcl mod full_loc (tcIfaceInst inst) - where - full_loc = loc $$ (nest 2 (ptext SLIT("instance decl") <+> ppr inst)) - -tcIfaceInst :: IfaceInst -> IfL DFunId -tcIfaceInst (IfaceInst { ifDFun = dfun_occ }) - = tcIfaceExtId (LocalTop dfun_occ) - -selectInsts :: Name -> [Name] -> ExternalPackageState - -> (ExternalPackageState, [(Module, SDoc, IfaceInst)]) -selectInsts cls tycons eps - = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts) +tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, + ifInstCls = cls, ifInstTys = mb_tcs, + ifInstOrph = orph }) + = do { dfun <- forkM (ptext SLIT("Dict fun") <+> ppr dfun_occ) $ + tcIfaceExtId (LocalTop dfun_occ) + ; cls' <- lookupIfaceExt cls + ; mb_tcs' <- mapM do_tc mb_tcs + ; return (mkImportedInstance cls' mb_tcs' orph dfun oflag) } where - insts = eps_insts eps - stats = eps_stats eps - stats' = stats { n_insts_out = n_insts_out stats + length iface_insts } - - (insts', iface_insts) - = case lookupNameEnv insts cls of { - Nothing -> (insts, []) ; - Just gated_insts -> - - case choose1 gated_insts of { - (_, []) -> (insts, []) ; -- None picked - (gated_insts', iface_insts') -> - - (extendNameEnv insts cls gated_insts', iface_insts') }} - - choose1 gated_insts - | null tycons -- Bizarre special case of C (a b); then there are no tycons - = ([], map snd gated_insts) -- Just grab all the instances, no real alternative - | otherwise -- Normal case - = foldl choose2 ([],[]) gated_insts - - -- Reverses the gated decls, but that doesn't matter - choose2 (gis, decls) (gates, decl) - | null gates -- Happens when we have 'instance T a where ...' - || any (`elem` tycons) gates = (gis, decl:decls) - | otherwise = ((gates,decl) : gis, decls) + do_tc Nothing = return Nothing + do_tc (Just tc) = do { tc' <- lookupIfaceTc tc; return (Just tc') } \end{code} + %************************************************************************ %* * Rules @@ -566,77 +483,40 @@ are in the type environment. However, remember that typechecking a Rule may (as a side effect) augment the type envt, and so we may need to iterate the process. \begin{code} -loadImportedRules :: HscEnv -> ModGuts -> IO [IdCoreRule] --- Returns just the new rules added -loadImportedRules hsc_env guts - = initIfaceRules hsc_env guts $ do - { -- Get new rules - if_rules <- updateEps selectRules - - ; traceIf (ptext SLIT("Importing rules:") <+> vcat [ppr r | (_,_,r) <- if_rules]) - - ; core_rules <- mapM tc_rule if_rules - - -- Debug print - ; traceIf (ptext SLIT("Imported rules:") <+> pprIdRules core_rules) - - -- Update the rule base and return it - ; updateEps (\ eps -> - let { new_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules } - in (eps { eps_rule_base = new_rule_base }, new_rule_base) - ) - - -- Strictly speaking, at this point we should go round again, since - -- typechecking one set of rules may bring in new things which enable - -- some more rules to come in. But we call loadImportedRules several - -- times anyway, so I'm going to be lazy and ignore this. - ; return core_rules - } - -tc_rule (mod, loc, rule) = initIfaceLcl mod full_loc (tcIfaceRule rule) - where - full_loc = loc $$ (nest 2 (ptext SLIT("rule") <+> ppr rule)) - -selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, SDoc, IfaceRule)]) --- Not terribly efficient. Look at each rule in the pool to see if --- all its gates are in the type env. If so, take it out of the pool. --- If not, trim its gates for next time. -selectRules eps - = (eps { eps_rules = rules', eps_stats = stats' }, if_rules) - where - stats = eps_stats eps - rules = eps_rules eps - type_env = eps_PTE eps - stats' = stats { n_rules_out = n_rules_out stats + length if_rules } - - (rules', if_rules) = foldl do_one ([], []) rules - - do_one (pool, if_rules) (gates, rule) - | null gates' = (pool, rule:if_rules) - | otherwise = ((gates',rule) : pool, if_rules) - where - gates' = filter (not . (`elemNameEnv` type_env)) gates - - -tcIfaceRule :: IfaceRule -> IfL IdCoreRule -tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn_rdr, ifRuleArgs = args, ifRuleRhs = rhs }) - = bindIfaceBndrs bndrs $ \ bndrs' -> - do { fn <- tcIfaceExtId fn_rdr - ; args' <- mappM tcIfaceExpr args - ; rhs' <- tcIfaceExpr rhs - ; let rule = Rule rule_name act bndrs' args' rhs' - ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) } +tcIfaceRule :: IfaceRule -> IfL CoreRule +tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs, + ifRuleOrph = orph }) + = do { fn' <- lookupIfaceExt fn + ; ~(bndrs', args', rhs') <- + -- Typecheck the payload lazily, in the hope it'll never be looked at + forkM (ptext SLIT("Rule") <+> ftext name) $ + bindIfaceBndrs bndrs $ \ bndrs' -> + do { args' <- mappM tcIfaceExpr args + ; rhs' <- tcIfaceExpr rhs + ; return (bndrs', args', rhs') } + ; mb_tcs <- mapM ifTopFreeName args + ; returnM (Rule { ru_name = name, ru_fn = fn', ru_act = act, + ru_bndrs = bndrs', ru_args = args', + ru_rhs = rhs', ru_orph = orph, + ru_rough = mb_tcs, + ru_local = isLocalIfaceExtName fn }) } where - -tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule) - = do { fn <- tcIfaceExtId fn_rdr - ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) } - -isOrphNm :: IfaceExtName -> Bool --- An orphan name comes from somewhere other than this module, --- so it has a non-local name -isOrphNm name = not (isLocalIfaceExtName name) + -- This function *must* mirror exactly what Rules.topFreeName does + -- We could have stored the ru_rough field in the iface file + -- but that would be redundant, I think. + -- The only wrinkle is that we must not be deceived by + -- type syononyms at the top of a type arg. Since + -- we can't tell at this point, we are careful not + -- to write them out in coreRuleToIfaceRule + ifTopFreeName :: IfaceExpr -> IfL (Maybe Name) + ifTopFreeName (IfaceType (IfaceTyConApp tc _ )) + = do { n <- lookupIfaceTc tc + ; return (Just n) } + ifTopFreeName (IfaceApp f a) = ifTopFreeName f + ifTopFreeName (IfaceExt ext) = do { n <- lookupIfaceExt ext + ; return (Just n) } + ifTopFreeName other = return Nothing \end{code} @@ -662,6 +542,7 @@ mkIfTcApp :: TyCon -> [Type] -> Type -- messages), but type synonyms can expand into non-hoisted types (ones with -- foralls to the right of an arrow), so we must be careful to hoist them here. -- This hack should go away when we get rid of hoisting. +-- Then we should go back to mkGenTyConApp or something like it mkIfTcApp tc tys | isSynTyCon tc = hoistForAllTys (mkSynTy tc tys) | otherwise = mkTyConApp tc tys @@ -952,6 +833,9 @@ tcPragExpr name expr \begin{code} tcIfaceGlobal :: Name -> IfL TyThing tcIfaceGlobal name + | Just thing <- wiredInNameTyThing_maybe name + = return thing + | otherwise = do { (eps,hpt) <- getEpsAndHpt ; case lookupType hpt (eps_PTE eps) name of { Just thing -> return thing ; diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs index 20487c41af..fbd2d49908 100644 --- a/ghc/compiler/main/DriverPipeline.hs +++ b/ghc/compiler/main/DriverPipeline.hs @@ -164,6 +164,7 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods let do_recomp = dopt Opt_RecompChecking dflags source_unchanged = isJust maybe_old_linkable && do_recomp hsc_env' = hsc_env { hsc_dflags = dflags' } + object_filename = ml_obj_file location -- run the compiler hsc_result <- hscMain hsc_env' msg_act mod_summary @@ -177,13 +178,16 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods ASSERT(isJust maybe_old_linkable) return (CompOK details iface maybe_old_linkable) - HscRecomp details iface - stub_h_exists stub_c_exists maybe_interpreted_code + HscRecomp details iface stub_h_exists stub_c_exists maybe_interpreted_code | isHsBoot src_flavour -- No further compilation to do - -> return (CompOK details iface Nothing) + -> do case hsc_lang of + HscInterpreted -> return () + _other -> SysTools.touch dflags' "Touching object file" + object_filename + return (CompOK details iface Nothing) - | otherwise -- Normal Haskell source files + | otherwise -- Normal source file -> do maybe_stub_o <- compileStub dflags' stub_c_exists let stub_unlinked = case maybe_stub_o of @@ -195,8 +199,8 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods -- in interpreted mode, just return the compiled code -- as our "unlinked" object. - HscInterpreted -> - case maybe_interpreted_code of + HscInterpreted + -> case maybe_interpreted_code of #ifdef GHCI Just comp_bc -> return ([BCOs comp_bc], ms_hs_date mod_summary) -- Why do we use the timestamp of the source file here, @@ -208,16 +212,14 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods #endif Nothing -> panic "compile: no interpreted code" - -- we're in batch mode: finish the compilation pipeline. - _other -> do - let object_filename = ml_obj_file location + -- We're in --make mode: finish the compilation pipeline. + _other + -> do runPipeline StopLn dflags output_fn Persistent + (Just location) + -- The object filename comes from the ModLocation - runPipeline StopLn dflags output_fn Persistent - (Just location) - -- the object filename comes from the ModLocation - - o_time <- getModificationTime object_filename - return ([DotO object_filename], o_time) + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) let linkable = LM unlinked_time this_mod (hs_unlinked ++ stub_unlinked) @@ -719,6 +721,9 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma HscNoRecomp details iface -> do SysTools.touch dflags' "Touching object file" o_file + -- The .o file must have a later modification date + -- than the source file (else we wouldn't be in HscNoRecomp) + -- but we touch it anyway, to keep 'make' happy (we think). return (StopLn, dflags', Just location4, o_file) HscRecomp _details _iface diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs index a2487d84b5..f2239f4182 100644 --- a/ghc/compiler/main/GHC.hs +++ b/ghc/compiler/main/GHC.hs @@ -156,6 +156,7 @@ import Id ( Id, idType, isImplicitId, isDeadBinder, import TyCon ( TyCon, isClassTyCon, isSynTyCon, isNewTyCon ) import Class ( Class, classSCTheta, classTvsFds ) import DataCon ( DataCon ) +import InstEnv ( Instance ) import Name ( Name, getName, nameModule_maybe ) import RdrName ( RdrName, gre_name, globalRdrEnvElts ) import NameEnv ( nameEnvElts ) @@ -1028,7 +1029,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary let -- The old interface is ok if it's in the old HPT -- a) we're compiling a source file, and the old HPT - -- entry is for a source file + -- entry is for a source file -- b) we're compiling a hs-boot file -- Case (b) allows an hs-boot file to get the interface of its -- real source file on the second iteration of the compilation diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 389731c0cd..8b3ad405be 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -20,13 +20,13 @@ module HscMain ( #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..), LHsExpr ) +import HsSyn ( Stmt(..), LHsExpr, LStmt, LHsType ) import IfaceSyn ( IfaceDecl, IfaceInst ) import Module ( Module ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) -import TidyPgm ( tidyCoreExpr ) +import CoreTidy ( tidyExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnGetInfo, GetInfoResult, tcRnType ) @@ -39,12 +39,13 @@ import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) import BasicTypes ( Fixity ) import SrcLoc ( SrcLoc, noSrcLoc ) +import VarEnv ( emptyTidyEnv ) #endif import Var ( Id ) import Module ( emptyModuleEnv ) import RdrName ( GlobalRdrEnv, RdrName ) -import HsSyn ( HsModule, LHsBinds, LStmt, LHsType, HsGroup ) +import HsSyn ( HsModule, LHsBinds, HsGroup ) import SrcLoc ( Located(..) ) import StringBuffer ( hGetStringBuffer, stringToStringBuffer ) import Parser @@ -56,11 +57,11 @@ import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) -import MkIface ( checkOldIface, mkIface ) +import MkIface ( checkOldIface, mkIface, writeIfaceFile ) import Desugar import Flattening ( flatten ) import SimplCore -import TidyPgm ( tidyCorePgm ) +import TidyPgm ( optTidyPgm, simpleTidyPgm ) import CorePrep ( corePrepPgm ) import CoreToStg ( coreToStg ) import Name ( Name, NamedThing(..) ) @@ -82,9 +83,7 @@ import ParserCore import ParserCoreUtils import FastString import Maybes ( expectJust ) -import StringBuffer ( StringBuffer ) import Bag ( unitBag, emptyBag ) - import Monad ( when ) import Maybe ( isJust ) import IO @@ -190,7 +189,6 @@ hscMain hsc_env msg_act mod_summary ------------------------------ --- hscNoRecomp definitely expects to have the old interface available hscNoRecomp hsc_env msg_act mod_summary have_object (Just old_iface) mb_mod_index @@ -216,22 +214,28 @@ hscNoRecomp hsc_env msg_act mod_summary ; return (HscNoRecomp new_details old_iface) } +hscNoRecomp hsc_env msg_act mod_summary + have_object Nothing + mb_mod_index + = panic "hscNoRecomp" -- hscNoRecomp definitely expects to + -- have the old interface available + ------------------------------ hscRecomp hsc_env msg_act mod_summary - have_object maybe_checked_iface + have_object maybe_old_iface mb_mod_index = case ms_hsc_src mod_summary of HsSrcFile -> do front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index - hscBackEnd hsc_env mod_summary maybe_checked_iface front_res + hscBackEnd hsc_env mod_summary maybe_old_iface front_res HsBootFile -> do front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index - hscBootBackEnd hsc_env mod_summary maybe_checked_iface front_res + hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res ExtCoreFile -> do front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary - hscBackEnd hsc_env mod_summary maybe_checked_iface front_res + hscBackEnd hsc_env mod_summary maybe_old_iface front_res hscCoreFrontEnd hsc_env msg_act mod_summary = do { ------------------- @@ -297,9 +301,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do { ; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-} deSugar hsc_env tc_result ; msg_act (warns, emptyBag) - ; case maybe_ds_result of - Nothing -> return Nothing - Just ds_result -> return (Just ds_result) + ; return maybe_ds_result }}}}} ------------------------------ @@ -337,7 +339,7 @@ hscFileCheck hsc_env msg_act mod_summary = do { md_exports = tcg_exports tc_result, md_insts = tcg_insts tc_result, md_rules = [panic "no rules"] } - -- rules are IdCoreRules, not the + -- Rules are CoreRules, not the -- RuleDecls we get out of the typechecker return (HscChecked rdr_module (tcg_rn_decls tc_result) @@ -350,12 +352,16 @@ hscFileCheck hsc_env msg_act mod_summary = do { hscBootBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult -- For hs-boot files, there's no code generation to do -hscBootBackEnd hsc_env mod_summary maybe_checked_iface Nothing +hscBootBackEnd hsc_env mod_summary maybe_old_iface Nothing = return HscFail -hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) - = do { final_iface <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env (ms_location mod_summary) - maybe_checked_iface ds_result +hscBootBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) + = do { tidy_pgm <- simpleTidyPgm hsc_env ds_result + + ; (new_iface, no_change) + <- {-# SCC "MkFinalIface" #-} + mkIface hsc_env maybe_old_iface tidy_pgm + + ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change ; let { final_details = ModDetails { md_types = mg_types ds_result, md_exports = mg_exports ds_result, @@ -365,17 +371,17 @@ hscBootBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) ; dumpIfaceStats hsc_env ; return (HscRecomp final_details - final_iface + new_iface False False Nothing) } ------------------------------ hscBackEnd :: HscEnv -> ModSummary -> Maybe ModIface -> Maybe ModGuts -> IO HscResult -hscBackEnd hsc_env mod_summary maybe_checked_iface Nothing +hscBackEnd hsc_env mod_summary maybe_old_iface Nothing = return HscFail -hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) +hscBackEnd hsc_env mod_summary maybe_old_iface (Just ds_result) = do { -- OMITTED: -- ; seqList imported_modules (return ()) @@ -421,8 +427,11 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) ------------------- -- TIDY ------------------- + ; let omit_prags = dopt Opt_OmitInterfacePragmas dflags ; tidy_result <- {-# SCC "CoreTidy" #-} - tidyCorePgm hsc_env simpl_result + if omit_prags + then simpleTidyPgm hsc_env simpl_result + else optTidyPgm hsc_env simpl_result -- Emit external core ; emitExternalCore dflags tidy_result @@ -437,15 +446,15 @@ hscBackEnd hsc_env mod_summary maybe_checked_iface (Just ds_result) -- This has to happen *after* code gen so that the back-end -- info has been set. Not yet clear if it matters waiting -- until after code output - ; new_iface <- {-# SCC "MkFinalIface" #-} - mkIface hsc_env (ms_location mod_summary) - maybe_checked_iface tidy_result + ; (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} + mkIface hsc_env maybe_old_iface tidy_result + + ; writeIfaceFile hsc_env (ms_location mod_summary) new_iface no_change -- Space leak reduction: throw away the new interface if -- we're in one-shot mode; we won't be needing it any -- more. - ; final_iface <- - if one_shot then return (error "no final iface") + ; final_iface <- if one_shot then return (error "no final iface") else return new_iface -- Build the final ModDetails (except in one-shot mode, where @@ -677,11 +686,13 @@ hscKcType hsc_env str \end{code} \begin{code} +#ifdef GHCI hscParseStmt :: DynFlags -> String -> IO (Maybe (Maybe (LStmt RdrName))) hscParseStmt = hscParseThing parseStmt hscParseType :: DynFlags -> String -> IO (Maybe (LHsType RdrName)) hscParseType = hscParseThing parseType +#endif hscParseIdentifier :: DynFlags -> String -> IO (Maybe (Located RdrName)) hscParseIdentifier = hscParseThing parseIdentifier @@ -769,7 +780,7 @@ compileExpr hsc_env this_mod rdr_env type_env tc_expr ; simpl_expr <- simplifyExpr dflags flat_expr -- Tidy it (temporary, until coreSat does cloning) - ; tidy_expr <- tidyCoreExpr simpl_expr + ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr -- Prepare for codegen ; prepd_expr <- corePrepExpr dflags tidy_expr diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 726c020648..b02debb83c 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -45,8 +45,6 @@ module HscTypes ( WhetherHasOrphans, IsBootInterface, Usage(..), Dependencies(..), noDependencies, - InstPool, Gated, addInstsToPool, - RulePool, addRulesToPool, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, @@ -54,7 +52,6 @@ module HscTypes ( Deprecations, DeprecTxt, lookupDeprec, plusDeprecs, - InstEnv, DFunId, PackageInstEnv, PackageRuleBase, -- Linker stuff @@ -78,7 +75,7 @@ import NameSet import OccName ( OccName, OccEnv, lookupOccEnv, mkOccEnv, emptyOccEnv, extendOccEnv ) import Module -import InstEnv ( InstEnv, DFunId ) +import InstEnv ( InstEnv, Instance ) import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import Id ( Id ) @@ -96,7 +93,7 @@ import BasicTypes ( Version, initialVersion, IPName, import IfaceSyn ( IfaceInst, IfaceRule, IfaceDecl(ifName) ) import FiniteMap ( FiniteMap ) -import CoreSyn ( IdCoreRule ) +import CoreSyn ( CoreRule ) import Maybes ( orElse, fromJust, expectJust ) import Outputable import SrcLoc ( SrcSpan ) @@ -245,18 +242,18 @@ lookupIfaceByModule hpt pit mod \begin{code} -hptInstances :: HscEnv -> (Module -> Bool) -> [DFunId] +hptInstances :: HscEnv -> (Module -> Bool) -> [Instance] -- Find all the instance declarations that are in modules imported -- by this one, directly or indirectly, and are in the Home Package Table -- This ensures that we don't see instances from modules --make compiled -- before this one, but which are not below this one hptInstances hsc_env want_this_module - = [ dfun + = [ ispec | mod_info <- moduleEnvElts (hsc_HPT hsc_env) , want_this_module (mi_module (hm_iface mod_info)) - , dfun <- md_insts (hm_details mod_info) ] + , ispec <- md_insts (hm_details mod_info) ] -hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [IdCoreRule] +hptRules :: HscEnv -> [(Module, IsBootInterface)] -> [CoreRule] -- Get rules from modules "below" this one (in the dependency sense) -- C.f Inst.hptInstances hptRules hsc_env deps @@ -359,10 +356,10 @@ data ModIface data ModDetails = ModDetails { -- The next three fields are created by the typechecker - md_types :: !TypeEnv, md_exports :: NameSet, - md_insts :: ![DFunId], -- Dfun-ids for the instances in this module - md_rules :: ![IdCoreRule] -- Domain may include Ids from other modules + md_types :: !TypeEnv, + md_insts :: ![Instance], -- Dfun-ids for the instances in this module + md_rules :: ![CoreRule] -- Domain may include Ids from other modules } emptyModDetails = ModDetails { md_types = emptyTypeEnv, @@ -390,8 +387,8 @@ data ModGuts mg_deprecs :: !Deprecations, -- Deprecations declared in the module mg_types :: !TypeEnv, - mg_insts :: ![DFunId], -- Instances - mg_rules :: ![IdCoreRule], -- Rules from this module + mg_insts :: ![Instance], -- Instances + mg_rules :: ![CoreRule], -- Rules from this module mg_binds :: ![CoreBind], -- Bindings for this module mg_foreign :: !ForeignStubs } @@ -817,7 +814,7 @@ data ExternalPackageState -- The ModuleIFaces for modules in external packages -- whose interfaces we have opened -- The declarations in these interface files are held in - -- eps_decls, eps_insts, eps_rules (below), not in the + -- eps_decls, eps_inst_env, eps_rules (below), not in the -- mi_decls fields of the iPIT. -- What _is_ in the iPIT is: -- * The Module @@ -832,18 +829,6 @@ data ExternalPackageState -- all the external-package modules eps_rule_base :: !PackageRuleBase, -- Ditto RuleEnv - - -- Holding pens for stuff that has been read in from file, - -- but not yet slurped into the renamer - eps_insts :: !InstPool, - -- The as-yet un-slurped instance decls - -- Decls move from here to eps_inst_env - -- Each instance is 'gated' by the names that must be - -- available before this instance decl is needed. - - eps_rules :: !RulePool, - -- The as-yet un-slurped rules - eps_stats :: !EpsStats } @@ -853,6 +838,14 @@ data EpsStats = EpsStats { n_ifaces_in , n_decls_in, n_decls_out , n_rules_in, n_rules_out , n_insts_in, n_insts_out :: !Int } + +addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats +-- Add stats for one newly-read interface +addEpsInStats stats n_decls n_insts n_rules + = stats { n_ifaces_in = n_ifaces_in stats + 1 + , n_decls_in = n_decls_in stats + n_decls + , n_insts_in = n_insts_in stats + n_insts + , n_rules_in = n_rules_in stats + n_rules } \end{code} The NameCache makes sure that there is just one Unique assigned for @@ -863,10 +856,6 @@ name, we might not be at its binding site (e.g. we are reading an interface file); so we give it 'noSrcLoc' then. Later, when we find its binding site, we fix it up. -Exactly the same is true of the Module stored in the Name. When we first -encounter the occurrence, we may not know the details of the module, so -we just store junk. Then when we find the binding site, we fix it up. - \begin{code} data NameCache = NameCache { nsUniqs :: UniqSupply, @@ -881,47 +870,6 @@ type OrigNameCache = ModuleEnv (OccEnv Name) type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \end{code} -\begin{code} -type Gated d = ([Name], (Module, SDoc, d)) - -- The [Name] 'gate' the declaration; always non-empty - -- Module records which module this decl belongs to - -- SDoc records the pathname of the file, or similar err-ctxt info - -type RulePool = [Gated IfaceRule] - -addRulesToPool :: RulePool - -> [Gated IfaceRule] - -> RulePool -addRulesToPool rules new_rules = new_rules ++ rules - -------------------------- -addEpsInStats :: EpsStats -> Int -> Int -> Int -> EpsStats --- Add stats for one newly-read interface -addEpsInStats stats n_decls n_insts n_rules - = stats { n_ifaces_in = n_ifaces_in stats + 1 - , n_decls_in = n_decls_in stats + n_decls - , n_insts_in = n_insts_in stats + n_insts - , n_rules_in = n_rules_in stats + n_rules } - -------------------------- -type InstPool = NameEnv [Gated IfaceInst] - -- The key of the Pool is the Class - -- The Names are the TyCons in the instance head - -- For example, suppose this is in an interface file - -- instance C T where ... - -- We want to slurp this decl if both C and T are "visible" in - -- the importing module. See "The gating story" in RnIfaces for details. - - -addInstsToPool :: InstPool -> [(Name, Gated IfaceInst)] -> InstPool -addInstsToPool insts new_insts - = foldr add insts new_insts - where - add :: (Name, Gated IfaceInst) -> NameEnv [Gated IfaceInst] -> NameEnv [Gated IfaceInst] - add (cls,new_inst) insts = extendNameEnv_C combine insts cls [new_inst] - where - combine old_insts _ = new_inst : old_insts -\end{code} %************************************************************************ diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 73ef49d5d9..ca7bceda38 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -4,41 +4,47 @@ \section{Tidying up Core} \begin{code} -module TidyPgm( tidyCorePgm, tidyCoreExpr ) where +module TidyPgm( simpleTidyPgm, optTidyPgm ) where #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..), dopt ) +import DynFlags ( DynFlags, DynFlag(..) ) import CoreSyn import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) -import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules ) -import PprCore ( pprIdRules ) +import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules ) +import PprCore ( pprRules ) import CoreLint ( showPass, endPass ) import CoreUtils ( exprArity, rhsIsStatic ) import VarEnv import VarSet import Var ( Id, Var ) -import Id ( idType, idInfo, idName, idCoreRules, +import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, isExportedId, mkVanillaGlobal, isLocalId, - isImplicitId, idArity, setIdInfo, idCafInfo + idArity, idCafInfo ) import IdInfo {- loads of stuff -} +import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive ) import Name ( Name, getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc, nameParent_maybe + localiseName, isExternalName, nameSrcLoc, nameParent_maybe, + isWiredInName, getName ) +import NameSet ( NameSet, elemNameSet ) import IfaceEnv ( allocateGlobalBinder ) -import NameEnv ( lookupNameEnv, filterNameEnv ) +import NameEnv ( filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) +import TcType ( isFFITy ) +import DataCon ( dataConName, dataConFieldLabels ) +import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, newTyConRep ) import Module ( Module ) import HscTypes ( HscEnv(..), NameCache( nsUniqs ), - TypeEnv, extendTypeEnvList, typeEnvIds, - ModGuts(..), ModGuts, TyThing(..) + TypeEnv, typeEnvIds, typeEnvElts, extendTypeEnvWithIds, mkTypeEnv, + ModGuts(..), ModGuts, TyThing(..) ) -import Maybes ( orElse ) +import Maybes ( orElse, mapCatMaybes ) import ErrUtils ( showPass, dumpIfSet_core ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) @@ -49,15 +55,160 @@ import FastTypes hiding ( fastOr ) \end{code} +Constructing the TypeEnv, Instances, Rules from which the ModIface is +constructed, and which goes on to subsequent modules in --make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +%************************************************************************ +%* * + Plan A: simpleTidyPgm +%* * +%************************************************************************ + + +Plan A: simpleTidyPgm: omit pragmas, make interfaces small +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + (why are they there? I think mainly as a memo + to avoid repeatedly checking that we've loaded their + home interface; but I'm not certain) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Leave the bindings untouched. There's no need to make the Ids + in the bindings into Globals, think, ever. + + +\begin{code} +simpleTidyPgm :: HscEnv -> ModGuts -> IO ModGuts +-- This is Plan A: make a small type env when typechecking only, +-- or when compiling a hs-boot file, or simply when not using -O + +simpleTidyPgm hsc_env mod_impl@(ModGuts { mg_exports = exports, + mg_types = type_env, + mg_insts = ispecs }) + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Tidy Type Env" + + ; let { ispecs' = tidyInstances tidyExternalId ispecs + + ; things' = mapCatMaybes (tidyThing exports) + (typeEnvElts type_env) + + ; type_env' = extendTypeEnvWithIds (mkTypeEnv things') + (map instanceDFunId ispecs') + } + + ; return (mod_impl { mg_types = type_env' + , mg_insts = ispecs' + , mg_rules = [] }) + } + +tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] +tidyInstances tidy_dfun ispecs + = map tidy ispecs + where + tidy ispec = setInstanceDFunId ispec (tidy_dfun (instanceDFunId ispec)) + +tidyThing :: NameSet -- Exports + -> TyThing -> Maybe TyThing -- Nothing => drop it +tidyThing exports thing + | isWiredInName (getName thing) + = Nothing + | otherwise + = case thing of + AClass cl -> Just thing + + ATyCon tc + | mustExposeTyCon exports tc -> Just thing + | otherwise -> Just (ATyCon (makeTyConAbstract tc)) + + ADataCon dc + | getName dc `elemNameSet` exports -> Just thing + | otherwise -> Nothing + + AnId id + | not (getName id `elemNameSet` exports) -> Nothing + | not (isLocalId id) -> Just thing -- Implicit Ids such as class ops, + -- data-con wrappers etc + | otherwise -> Just (AnId (tidyExternalId id)) + +tidyExternalId :: Id -> Id +-- Takes an LocalId with an External Name, +-- makes it into a GlobalId with VanillaIdInfo, and tidies its type +-- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) +tidyExternalId id + = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) + mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo + +mustExposeTyCon :: NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon exports tc + = any exported_con (tyConDataCons tc) + -- Expose rep if any datacon or field is exported + + || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) + -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + where + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) +\end{code} + + %************************************************************************ %* * -\subsection{What goes on} + Plan B: tidy bindings, make TypeEnv full of IdInfo %* * %************************************************************************ -[SLPJ: 19 Nov 00] +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Figure out which Ids are externally visible + +* Tidy the bindings, externalising appropriate Ids -The plan is this. +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) Step 1: Figure out external Ids ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -78,7 +229,9 @@ Step 2: Tidy the program Next we traverse the bindings top to bottom. For each *top-level* binder - 1. Make it into a GlobalId + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id 2. Give it a system-wide Unique. [Even non-exported things need system-wide Uniques because the @@ -91,19 +244,16 @@ binder to ensure that the unique assigned is the same as the Id had in any previous compilation run. - 3. If it's an external Id, make it have a global Name, otherwise - make it have a local Name. + 3. If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. This is used by the code generator to decide whether to make the label externally visible - 4. Give external Ids a "tidy" occurrence name. This means + 4. Give external Ids a "tidy" OccName. This means we can print them in interface files without confusing "x" (unique 5) with "x" (unique 10). 5. Give it its UTTERLY FINAL IdInfo; in ptic, - * Its IdDetails becomes VanillaGlobal, reflecting the fact that - from now on we regard it as a global, not local, Id - * its unfolding, if it should have one * its arity, computed from the number of visible lambdas @@ -116,101 +266,55 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts +optTidyPgm :: HscEnv -> ModGuts -> IO ModGuts -tidyCorePgm hsc_env - mod_impl@(ModGuts { mg_module = mod, +optTidyPgm hsc_env + mod_impl@(ModGuts { mg_module = mod, mg_types = env_tc, mg_insts = insts_tc, - mg_binds = binds_in, mg_rules = orphans_in }) - = do { let { dflags = hsc_dflags hsc_env - ; nc_var = hsc_NC hsc_env } + mg_binds = binds_in, + mg_rules = imp_rules }) + = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Tidy Core" - ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags - ; let ext_ids = findExternalSet omit_iface_prags binds_in - ; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids - -- findExternalRules filters ext_rules to avoid binders that + ; let ext_ids = findExternalIds binds_in + ; let ext_rules = findExternalRules binds_in imp_rules ext_ids + -- findExternalRules filters imp_rules to avoid binders that -- aren't externally visible; but the externally-visible binders - -- are computed (by findExternalSet) assuming that all orphan + -- are computed (by findExternalIds) assuming that all orphan -- rules are exported (they get their Exported flag set in the desugarer) -- So in fact we may export more than we need. -- (It's a sort of mutual recursion.) - -- We also make sure to avoid any exported binders. Consider - -- f{-u1-} = 1 -- Local decl - -- ... - -- f{-u2-} = 2 -- Exported decl - -- - -- The second exported decl must 'get' the name 'f', so we - -- have to put 'f' in the avoids list before we get to the first - -- decl. tidyTopId then does a no-op on exported binders. - ; let init_env = (initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, - let name = idName bndr, - isExternalName name] - -- In computing our "avoids" list, we must include - -- all implicit Ids - -- all things with global names (assigned once and for - -- all by the renamer) - -- since their names are "taken". - -- The type environment is a convenient source of such things. - - ; (final_env, tidy_binds) - <- tidyTopBinds dflags mod nc_var ext_ids init_env binds_in - - ; let tidy_rules = tidyIdRules final_env ext_rules - - ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds - - -- Dfuns are local Ids that might have - -- changed their unique during tidying. Remember - -- to lookup the id in the TypeEnv too, because - -- those Ids have had their IdInfo stripped if - -- necessary. - ; let (_, subst_env ) = final_env - lookup_dfun_id id = - case lookupVarEnv subst_env id of - Nothing -> dfun_panic - Just id -> - case lookupNameEnv tidy_type_env (idName id) of - Just (AnId id) -> id - _other -> dfun_panic - where - dfun_panic = pprPanic "lookup_dfun_id" (ppr id) + ; (final_env, tidy_binds) <- tidyTopBinds hsc_env mod env_tc + ext_ids binds_in - tidy_dfun_ids = map lookup_dfun_id insts_tc - - ; let tidy_result = mod_impl { mg_types = tidy_type_env, - mg_rules = tidy_rules, - mg_insts = tidy_dfun_ids, - mg_binds = tidy_binds } + ; let { tidy_rules = tidyRules final_env ext_rules + ; tidy_type_env = tidyTypeEnv env_tc tidy_binds + ; tidy_ispecs = tidyInstances (tidyVarOcc final_env) insts_tc + -- A DFunId will have a binding in tidy_binds, and so + -- will now be in final_env, replete with IdInfo + -- Its name will be unchanged since it was born, but + -- we want Global, IdInfo-rich DFunId in the tidy_ispecs + } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" - (pprIdRules tidy_rules) + (pprRules tidy_rules) - ; return tidy_result + ; return (mod_impl { mg_types = tidy_type_env, + mg_rules = tidy_rules, + mg_insts = tidy_ispecs, + mg_binds = tidy_binds }) } -tidyCoreExpr :: CoreExpr -> IO CoreExpr -tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) -\end{code} - -%************************************************************************ -%* * -\subsection{Write a new interface file} -%* * -%************************************************************************ - -\begin{code} -mkFinalTypeEnv :: Bool -- Omit interface pragmas - -> TypeEnv -- From typechecker - -> [CoreBind] -- Final Ids - -> TypeEnv +tidyTypeEnv :: TypeEnv -- From typechecker + -> [CoreBind] -- Final Ids + -> TypeEnv -- The competed type environment is gotten from +-- Dropping any wired-in things, and then -- a) keeping the types and classes -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, @@ -220,81 +324,21 @@ mkFinalTypeEnv :: Bool -- Omit interface pragmas -- the externally-accessible ones -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space --- --- However, we do keep things like constructors, which should not appear --- in interface files, because they are needed by importing modules when --- using the compilation manager -mkFinalTypeEnv omit_iface_prags type_env tidy_binds - = extendTypeEnvList (filterNameEnv keep_it type_env) final_ids +tidyTypeEnv type_env tidy_binds + = extendTypeEnvWithIds (filterNameEnv keep_it type_env) final_ids where - final_ids = [ AnId (strip_id_info id) + final_ids = [ id | bind <- tidy_binds, id <- bindersOf bind, isExternalName (idName id)] - strip_id_info id - | omit_iface_prags = id `setIdInfo` vanillaIdInfo - | otherwise = id - -- If the interface file has no pragma info then discard all - -- info right here. - -- - -- This is not so important for *this* module, but it's - -- vital for ghc --make: - -- subsequent compilations must not see (e.g.) the arity if - -- the interface file does not contain arity - -- If they do, they'll exploit the arity; then the arity might - -- change, but the iface file doesn't change => recompilation - -- does not happen => disaster - -- - -- This IdInfo will live long-term in the Id => vanillaIdInfo makes - -- a conservative assumption about Caf-hood - -- - -- We're not worried about occurrences of these Ids in unfoldings, - -- because in OmitInterfacePragmas mode we're stripping all the - -- unfoldings anyway. - - -- We keep implicit Ids, because they won't appear + -- We keep GlobalIds, because they won't appear -- in the bindings from which final_ids are derived! - keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones - keep_it other = True -- Keep all TyCons and Classes -\end{code} - -\begin{code} -findExternalRules :: Bool -- Omit interface pragmas - -> [CoreBind] - -> [IdCoreRule] -- Orphan rules - -> IdEnv a -- Ids that are exported, so we need their rules - -> [IdCoreRule] - -- The complete rules are gotten by combining - -- a) the orphan rules - -- b) rules embedded in the top-level Ids -findExternalRules omit_iface_prags binds orphan_rules ext_ids - | omit_iface_prags = [] - | otherwise - = filter (not . internal_rule) (orphan_rules ++ local_rules) - where - local_rules = [ rule - | id <- bindersOfBinds binds, - id `elemVarEnv` ext_ids, - rule <- idCoreRules id - ] - internal_rule (IdCoreRule id is_orphan rule) - = 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 - - || (not is_orphan && internal_id id) - -- Rule for an Id in this module; internal if the - -- Id is not exported - - || any internal_id (varSetElems (ruleLhsFreeIds rule)) - -- Don't export a rule whose LHS mentions an Id that - -- is completely internal (i.e. not visible to an - -- importing module) - - internal_id id = not (id `elemVarEnv` ext_ids) + -- (The bindings bind LocalIds.) + keep_it thing | isWiredInName (getName thing) = False + keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops) + keep_it other = True -- Keep all TyCons, DataCons, and Classes \end{code} %************************************************************************ @@ -304,16 +348,15 @@ findExternalRules omit_iface_prags binds orphan_rules ext_ids %************************************************************************ \begin{code} -findExternalSet :: Bool -- Omit interface pragmas - -> [CoreBind] +findExternalIds :: [CoreBind] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above -findExternalSet omit_iface_prags binds +findExternalIds binds = foldr find emptyVarEnv binds where find (NonRec id rhs) needed - | need_id needed id = addExternal omit_iface_prags (id,rhs) needed + | need_id needed id = addExternal (id,rhs) needed | otherwise = needed find (Rec prs) needed = find_prs prs needed @@ -323,7 +366,7 @@ findExternalSet omit_iface_prags binds | otherwise = find_prs other_prs new_needed where (needed_prs, other_prs) = partition (need_pr needed) prs - new_needed = foldr (addExternal omit_iface_prags) needed needed_prs + new_needed = foldr addExternal needed needed_prs -- 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 @@ -331,10 +374,10 @@ findExternalSet omit_iface_prags binds need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id need_pr needed_set (id,rhs) = need_id needed_set id -addExternal :: Bool -> (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool +addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool -- The Id is needed; extend the needed set -- with it and its dependents (free vars etc) -addExternal omit_iface_prags (id,rhs) needed +addExternal (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where @@ -342,16 +385,15 @@ addExternal omit_iface_prags (id,rhs) needed -- "False" because we don't know we need the Id's unfolding -- We'll override it later when we find the binding site - new_needed_ids | omit_iface_prags = emptyVarSet - | otherwise = worker_ids `unionVarSet` - unfold_ids `unionVarSet` - spec_ids + new_needed_ids = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) loop_breaker = isLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) - spec_ids = rulesRhsFreeVars (specInfo idinfo) + spec_ids = specInfoFreeVars (specInfo idinfo) worker_info = workerInfo idinfo -- Stuff to do with the Id's unfolding @@ -378,6 +420,34 @@ addExternal omit_iface_prags (id,rhs) needed \end{code} +\begin{code} +findExternalRules :: [CoreBind] + -> [CoreRule] -- Non-local rules (i.e. ones for imported fns) + -> IdEnv a -- Ids that are exported, so we need their rules + -> [CoreRule] + -- The complete rules are gotten by combining + -- a) the non-local rules + -- b) rules embedded in the top-level Ids +findExternalRules binds non_local_rules ext_ids + = filter (not . internal_rule) (non_local_rules ++ local_rules) + where + local_rules = [ rule + | id <- bindersOfBinds binds, + id `elemVarEnv` ext_ids, + rule <- idCoreRules id + ] + + internal_rule rule + = any internal_id (varSetElems (ruleLhsFreeIds rule)) + -- Don't export a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module) + + internal_id id = not (id `elemVarEnv` ext_ids) +\end{code} + + + %************************************************************************ %* * \subsection{Step 2: top-level tidying} @@ -400,20 +470,43 @@ addExternal omit_iface_prags (id,rhs) needed -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -tidyTopBinds :: DynFlags +tidyTopBinds :: HscEnv -> Module - -> IORef NameCache -- For allocating new unique names + -> TypeEnv -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> TidyEnv -> [CoreBind] + -> [CoreBind] -> IO (TidyEnv, [CoreBind]) -tidyTopBinds dflags mod nc_var ext_ids tidy_env [] - = return (tidy_env, []) -tidyTopBinds dflags mod nc_var ext_ids tidy_env (b:bs) - = do { (tidy_env1, b') <- tidyTopBind dflags mod nc_var ext_ids tidy_env b - ; (tidy_env2, bs') <- tidyTopBinds dflags mod nc_var ext_ids tidy_env1 bs - ; return (tidy_env2, b':bs') } +tidyTopBinds hsc_env mod env_tc ext_ids binds + = go init_env binds + where + dflags = hsc_dflags hsc_env + nc_var = hsc_NC hsc_env + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds env_tc, + let name = idName bndr, + isExternalName name] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. + + go env [] = return (env, []) + go env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b + ; (env2, bs') <- go env1 bs + ; return (env2, b':bs') } ------------------------ tidyTopBind :: DynFlags @@ -510,7 +603,7 @@ tidyTopName mod nc_var ext_ids occ_env id -- whether we have already assigned a unique for it. -- If so, use it; if not, extend the table. -- All this is done by allcoateGlobalBinder. - -- This is needed when *re*-compiling a module in GHCi; we want to + -- This is needed when *re*-compiling a module in GHCi; we must -- use the same name for externally-visible things as we did before. diff --git a/ghc/compiler/prelude/PrelRules.lhs b/ghc/compiler/prelude/PrelRules.lhs index 04b24c3b12..e0b234782e 100644 --- a/ghc/compiler/prelude/PrelRules.lhs +++ b/ghc/compiler/prelude/PrelRules.lhs @@ -31,7 +31,6 @@ import Literal ( Literal(..), mkMachInt, mkMachWord , float2DoubleLit, double2FloatLit ) import PrimOp ( PrimOp(..), primOpOcc ) --- gaw 2004 import TysWiredIn ( boolTy, trueDataConId, falseDataConId ) import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) @@ -56,14 +55,19 @@ import DATA_WORD ( Word64 ) \begin{code} -primOpRules :: PrimOp -> [CoreRule] -primOpRules op = primop_rule op +primOpRules :: PrimOp -> Name -> [CoreRule] +primOpRules op op_name = primop_rule op where - op_name = mkFastString (occNameUserString (primOpOcc op)) - op_name_case = op_name `appendFS` FSLIT("->case") + rule_name = mkFastString (occNameUserString (primOpOcc op)) + rule_name_case = rule_name `appendFS` FSLIT("->case") -- A useful shorthand - one_rule rule_fn = [BuiltinRule op_name rule_fn] + one_rule rule_fn = [BuiltinRule { ru_name = rule_name, + ru_fn = op_name, + ru_try = rule_fn }] + case_rule rule_fn = [BuiltinRule { ru_name = rule_name_case, + ru_fn = op_name, + ru_try = rule_fn }] -- ToDo: something for integer-shift ops? -- NotOp @@ -127,10 +131,10 @@ primOpRules op = primop_rule op primop_rule DoubleNegOp = one_rule (oneLit negOp) -- Relational operators - primop_rule IntEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)] - primop_rule IntNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)] - primop_rule CharEqOp = [BuiltinRule op_name (relop (==)), BuiltinRule op_name_case (litEq True)] - primop_rule CharNeOp = [BuiltinRule op_name (relop (/=)), BuiltinRule op_name_case (litEq False)] + primop_rule IntEqOp = one_rule (relop (==)) ++ case_rule (litEq True) + primop_rule IntNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) + primop_rule CharEqOp = one_rule (relop (==)) ++ case_rule (litEq True) + primop_rule CharNeOp = one_rule (relop (/=)) ++ case_rule (litEq False) primop_rule IntGtOp = one_rule (relop (>)) primop_rule IntGeOp = one_rule (relop (>=)) @@ -401,11 +405,11 @@ dataToTagRule other = Nothing %************************************************************************ \begin{code} -builtinRules :: [(Name, CoreRule)] +builtinRules :: [CoreRule] -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules - = [ (unpackCStringFoldrName, BuiltinRule FSLIT("AppendLitString") match_append_lit), - (eqStringName, BuiltinRule FSLIT("EqString") match_eq_string) + = [ BuiltinRule FSLIT("AppendLitString") unpackCStringFoldrName match_append_lit, + BuiltinRule FSLIT("EqString") eqStringName match_eq_string ] diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 9dc312d290..6fa1dafc94 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -21,9 +21,9 @@ module TysWiredIn ( charTy, stringTy, charTyConName, - doubleTyCon, doubleDataCon, doubleTy, + doubleTyCon, doubleDataCon, doubleTy, doubleTyConName, - floatTyCon, floatDataCon, floatTy, + floatTyCon, floatDataCon, floatTy, floatTyConName, intTyCon, intDataCon, intTyCon_RDR, intDataCon_RDR, intTyConName, intTy, @@ -176,7 +176,8 @@ pcTyCon is_enum is_rec name tyvars argvrcs cons (mkArrowKinds (map tyVarKind tyvars) liftedTypeKind) tyvars argvrcs - (DataTyCon (Just []) cons is_enum) + [] -- No stupid theta + (DataTyCon cons is_enum) [] -- No record selectors is_rec True -- All the wired-in tycons have generics diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 116f9de411..55a3481cd3 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -428,10 +428,10 @@ lookupFixityRn name -- -- loadHomeInterface will find B.hi even if B is a hidden module, -- and that's what we want. - initIfaceTcRn (loadHomeInterface doc name) `thenM` \ iface -> + loadHomeInterface doc name `thenM` \ iface -> returnM (mi_fix_fn iface (nameOccName name)) where - doc = ptext SLIT("Checking fixity for") <+> ppr name + doc = ptext SLIT("Checking fixity for") <+> ppr name dataTcOccs :: RdrName -> [RdrName] -- If the input is a data constructor, return both it and a type diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index a1d21eb8a7..aef322610b 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -759,8 +759,8 @@ rnStmt ctxt (ParStmt stmtss) thing_inside return ((), emptyFVs) cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 - dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") - <+> quotes (ppr v)) + dupErr vs = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") + <+> quotes (ppr (head vs))) rnStmt ctxt (RecStmt rec_stmts _ _ _ _) thing_inside = bindLocatedLocalsRn doc (collectLStmtsBinders rec_stmts) $ \ _ -> diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 241863a8cb..6a82c56ac6 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -606,6 +606,7 @@ filterAvail (IEThingWith _ rdrs) n subs where env = mkOccEnv [(nameOccName s, s) | s <- subNames subs n] mb_names = map (lookupOccEnv env . rdrNameOcc) rdrs +filterAvail (IEModuleContents _) _ _ = panic "filterAvail" subNames :: NameEnv [Name] -> Name -> [Name] subNames env n = lookupNameEnv env n `orElse` [] @@ -874,6 +875,8 @@ warnDuplicateImports gres warn (GRE { gre_name = name, gre_prov = Imported imps _ }) = addWarn ((quotes (ppr name) <+> ptext SLIT("is imported more than once:")) $$ nest 2 (vcat (map ppr imps))) + warn gre = panic "warnDuplicateImports" + -- The GREs should all have Imported provenance -- ToDo: deal with original imports with 'qualified' and 'as M' clauses diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index e0c62c1bc4..29d138e4a6 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -12,7 +12,7 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalysePgm, occurAnalyseGlobalExpr, occurAnalyseRule, + occurAnalysePgm, occurAnalyseGlobalExpr ) where #include "HsVersions.h" @@ -25,6 +25,7 @@ import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, isExportedId, idArity, idSpecialisation, idType, idUnique, Id ) +import IdInfo ( isEmptySpecInfo ) import BasicTypes ( OccInfo(..), isOneOcc ) import VarSet @@ -68,15 +69,6 @@ occurAnalyseGlobalExpr expr = -- Top level expr, so no interesting free vars, and -- discard occurence info returned snd (occAnal initOccEnv expr) - -occurAnalyseRule :: CoreRule -> CoreRule -occurAnalyseRule rule@(BuiltinRule _ _) = rule -occurAnalyseRule (Rule str act tpl_vars tpl_args rhs) - -- Add occ info to tpl_vars, rhs - = Rule str act tpl_vars' tpl_args rhs' - where - (rhs_uds, rhs') = occAnal initOccEnv rhs - (_, tpl_vars') = tagBinders rhs_uds tpl_vars \end{code} @@ -332,7 +324,7 @@ reOrderRec env (CyclicSCC (bind : binds)) | inlineCandidate bndr rhs = 2 -- Likely to be inlined - | not (isEmptyCoreRules (idSpecialisation bndr)) = 1 + | not (isEmptySpecInfo (idSpecialisation bndr)) = 1 -- Avoid things with specialisations; we'd like -- to take advantage of them in the subsequent bindings @@ -434,7 +426,7 @@ occAnal env (Var v) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. - -- But that went wrong right after specialisation, when + -- Btu that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs index 8f7c98c0f4..4b1c01dfec 100644 --- a/ghc/compiler/simplCore/SetLevels.lhs +++ b/ghc/compiler/simplCore/SetLevels.lhs @@ -64,7 +64,7 @@ import Id ( Id, idType, mkSysLocalUnencoded, isOneShotLambda, zapDemandIdInfo, idSpecialisation, idWorkerInfo, setIdInfo ) -import IdInfo ( workerExists, vanillaIdInfo, ) +import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo ) import Var ( Var ) import VarSet import VarEnv @@ -773,7 +773,7 @@ absVarsOf dest_lvl (_, lvl_env, _, id_env) v -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) zap v | isId v = WARN( workerExists (idWorkerInfo v) || - not (isEmptyCoreRules (idSpecialisation v)), + not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo | otherwise = v diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index d785cdcbc2..03486c7662 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -12,18 +12,18 @@ import DynFlags ( CoreToDo(..), SimplifierSwitch(..), SimplifierMode(..), DynFlags, DynFlag(..), dopt, getCoreToDo ) import CoreSyn -import TcIface ( loadImportedRules ) import HscTypes ( HscEnv(..), ModGuts(..), ExternalPackageState(..), Dependencies( dep_mods ), hscEPS, hptRules ) import CSE ( cseProgram ) -import Rules ( RuleBase, ruleBaseIds, emptyRuleBase, - extendRuleBaseList, pprRuleBase, ruleCheckProgram ) -import PprCore ( pprCoreBindings, pprCoreExpr, pprIdRules ) +import Rules ( RuleBase, emptyRuleBase, mkRuleBase, unionRuleBase, + extendRuleBaseList, pprRuleBase, ruleCheckProgram, + mkSpecInfo, addSpecInfo ) +import PprCore ( pprCoreBindings, pprCoreExpr, pprRules ) import OccurAnal ( occurAnalysePgm, occurAnalyseGlobalExpr ) import IdInfo ( setNewStrictnessInfo, newStrictnessInfo, setWorkerInfo, workerInfo, - setSpecInfo, specInfo ) + setSpecInfo, specInfo, specInfoRules ) import CoreUtils ( coreBindsSize ) import Simplify ( simplTopBinds, simplExpr ) import SimplEnv ( SimplEnv, simplBinders, mkSimplEnv, setInScopeSet ) @@ -33,11 +33,11 @@ import CoreLint ( endPass ) import VarEnv ( mkInScopeSet ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( Id, modifyIdInfo, idInfo, idIsFrom, isExportedId, isLocalId, - idSpecialisation, setIdSpecialisation ) -import Rules ( addRules ) +import Id ( Id, modifyIdInfo, idInfo, isExportedId, isLocalId, + idSpecialisation, setIdSpecialisation, idName ) import VarSet import VarEnv +import NameEnv ( lookupNameEnv ) import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) import Specialise ( specProgram) @@ -79,9 +79,9 @@ core2core hsc_env guts (imp_rule_base, guts') <- prepareRules hsc_env guts ru_us -- DO THE BUSINESS - (stats, guts'') <- doCorePasses hsc_env cp_us + (stats, guts'') <- doCorePasses hsc_env imp_rule_base cp_us (zeroSimplCount dflags) - imp_rule_base guts' core_todos + guts' core_todos dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" @@ -116,21 +116,21 @@ gentleSimplEnv = mkSimplEnv SimplGently emptyRuleBase doCorePasses :: HscEnv + -> RuleBase -- the imported main rule base -> UniqSupply -- uniques -> SimplCount -- simplifier stats - -> RuleBase -- the main rule base -> ModGuts -- local binds in (with rules attached) -> [CoreToDo] -- which passes to do -> IO (SimplCount, ModGuts) -doCorePasses hsc_env us stats rb guts [] +doCorePasses hsc_env rb us stats guts [] = return (stats, guts) -doCorePasses hsc_env us stats rb guts (to_do : to_dos) +doCorePasses hsc_env rb us stats guts (to_do : to_dos) = do let (us1, us2) = splitUniqSupply us - (stats1, rb1, guts1) <- doCorePass to_do hsc_env us1 rb guts - doCorePasses hsc_env us2 (stats `plusSimplCount` stats1) rb1 guts1 to_dos + (stats1, guts1) <- doCorePass to_do hsc_env us1 rb guts + doCorePasses hsc_env rb us2 (stats `plusSimplCount` stats1) guts1 to_dos doCorePass (CoreDoSimplify mode sws) = _scc_ "Simplify" simplifyPgm mode sws doCorePass CoreCSE = _scc_ "CommonSubExpr" trBinds cseProgram @@ -165,29 +165,29 @@ ruleCheck phase pat dflags binds = do showPass dflags "RuleCheck" -- Most passes return no stats and don't change rules trBinds :: (DynFlags -> [CoreBind] -> IO [CoreBind]) -> HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, RuleBase, ModGuts) + -> IO (SimplCount, ModGuts) trBinds do_pass hsc_env us rb guts = do { binds' <- do_pass dflags (mg_binds guts) - ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) } + ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) } where dflags = hsc_dflags hsc_env trBindsU :: (DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind]) -> HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, RuleBase, ModGuts) + -> IO (SimplCount, ModGuts) trBindsU do_pass hsc_env us rb guts = do { binds' <- do_pass dflags us (mg_binds guts) - ; return (zeroSimplCount dflags, rb, guts { mg_binds = binds' }) } + ; return (zeroSimplCount dflags, guts { mg_binds = binds' }) } where dflags = hsc_dflags hsc_env -- Observer passes just peek; don't modify the bindings at all observe :: (DynFlags -> [CoreBind] -> IO a) -> HscEnv -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, RuleBase, ModGuts) + -> IO (SimplCount, ModGuts) observe do_pass hsc_env us rb guts = do { binds <- do_pass dflags (mg_binds guts) - ; return (zeroSimplCount dflags, rb, guts) } + ; return (zeroSimplCount dflags, guts) } where dflags = hsc_dflags hsc_env \end{code} @@ -210,8 +210,9 @@ prepareRules :: HscEnv -> UniqSupply -> IO (RuleBase, -- Rule base for imported things, incl -- (a) rules defined in this module (orphans) - -- (b) rules from other packages - -- (c) rules from other modules in home package + -- (b) rules from other modules in home package + -- but not things from other packages + ModGuts) -- Modified fields are -- (a) Bindings have rules attached, -- (b) Rules are now just orphan rules @@ -219,36 +220,15 @@ prepareRules :: HscEnv prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) guts@(ModGuts { mg_binds = binds, mg_deps = deps, mg_rules = local_rules }) us - = do { eps <- hscEPS hsc_env - - ; let -- Simplify the local rules; boringly, we need to make an in-scope set + = do { let -- Simplify the local rules; boringly, we need to make an in-scope set -- from the local binders, to avoid warnings from Simplify.simplVar local_ids = mkInScopeSet (mkVarSet (bindersOfBinds binds)) env = setInScopeSet gentleSimplEnv local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) home_pkg_rules = hptRules hsc_env (dep_mods deps) - (orphan_rules, rules_for_locals) = partition isOrphanRule better_rules - -- Get the rules for locally-defined Ids out of the RuleBase - -- If we miss any rules for Ids defined here, then we end up - -- giving the local decl a new Unique (because the in-scope-set is (hackily) the - -- same as the non-local-rule-id set, so the Id looks as if it's in scope - -- and hence should be cloned), and now the binding for the class method - -- doesn't have the same Unique as the one in the Class and the tc-env - -- Example: class Foo a where - -- op :: a -> a - -- {-# RULES "op" op x = x #-} - - -- NB: we assume that the imported rules dont include - -- rules for Ids in this module; if there is, the above bad things may happen - - pkg_rule_base = eps_rule_base eps - hpt_rule_base = extendRuleBaseList pkg_rule_base home_pkg_rules - imp_rule_base = extendRuleBaseList hpt_rule_base orphan_rules - - -- Update the binders in the local bindings with the lcoal rules - -- Update the binders of top-level bindings by - -- attaching the rules for each locally-defined Id to that Id. + -- Find the rules for locally-defined Ids; then we can attach them + -- to the binders in the top-level bindings -- -- Reason -- - It makes the rules easier to look up @@ -262,34 +242,32 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) -- which is extended on each iteration by the new wave of -- local binders; any rules which aren't on the binding will -- thereby get dropped + (rules_for_locals, rules_for_imps) = partition isLocalRule better_rules local_rule_base = extendRuleBaseList emptyRuleBase rules_for_locals binds_w_rules = updateBinders local_rule_base binds + hpt_rule_base = mkRuleBase home_pkg_rules + imp_rule_base = extendRuleBaseList hpt_rule_base rules_for_imps + ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" - (vcat [text "Local rules", pprIdRules better_rules, + (vcat [text "Local rules", pprRules better_rules, text "", text "Imported rules", pprRuleBase imp_rule_base]) -#ifdef DEBUG - ; let bad_rules = filter (idIsFrom (mg_module guts)) - (varSetElems (ruleBaseIds imp_rule_base)) - ; WARN( not (null bad_rules), ppr bad_rules ) return () -#endif - ; return (imp_rule_base, guts { mg_binds = binds_w_rules, mg_rules = orphan_rules }) + ; return (imp_rule_base, guts { mg_binds = binds_w_rules, + mg_rules = rules_for_imps }) } updateBinders :: RuleBase -> [CoreBind] -> [CoreBind] -updateBinders rule_base binds +updateBinders local_rules binds = map update_bndrs binds where - rule_ids = ruleBaseIds rule_base - update_bndrs (NonRec b r) = NonRec (update_bndr b) r update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] - update_bndr bndr = case lookupVarSet rule_ids bndr of - Nothing -> bndr - Just id -> bndr `setIdSpecialisation` idSpecialisation id + update_bndr bndr = case lookupNameEnv local_rules (idName bndr) of + Nothing -> bndr + Just rules -> bndr `setIdSpecialisation` mkSpecInfo rules \end{code} @@ -300,13 +278,13 @@ which without simplification looked like: This doesn't match unless you do eta reduction on the build argument. \begin{code} -simplRule env rule@(IdCoreRule id _ (BuiltinRule _ _)) +simplRule env rule@(BuiltinRule {}) = returnSmpl rule -simplRule env (IdCoreRule id is_orph (Rule act name bndrs args rhs)) +simplRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs }) = simplBinders env bndrs `thenSmpl` \ (env, bndrs') -> mapSmpl (simplExprGently env) args `thenSmpl` \ args' -> simplExprGently env rhs `thenSmpl` \ rhs' -> - returnSmpl (IdCoreRule id is_orph (Rule act name bndrs' args' rhs')) + returnSmpl (rule { ru_bndrs = bndrs', ru_args = args', ru_rhs = rhs' }) -- It's important that simplExprGently does eta reduction. -- For example, in a rule like: @@ -394,14 +372,14 @@ simplifyPgm :: SimplifierMode -> UniqSupply -> RuleBase -> ModGuts - -> IO (SimplCount, RuleBase, ModGuts) -- New bindings + -> IO (SimplCount, ModGuts) -- New bindings -simplifyPgm mode switches hsc_env us rule_base guts +simplifyPgm mode switches hsc_env us imp_rule_base guts = do { showPass dflags "Simplify"; - (termination_msg, it_count, counts_out, rule_base', binds') - <- do_iteration us rule_base 1 (zeroSimplCount dflags) (mg_binds guts) ; + (termination_msg, it_count, counts_out, binds') + <- do_iteration us 1 (zeroSimplCount dflags) (mg_binds guts) ; dumpIfSet (dopt Opt_D_verbose_core2core dflags && dopt Opt_D_dump_simpl_stats dflags) @@ -412,18 +390,18 @@ simplifyPgm mode switches hsc_env us rule_base guts endPass dflags "Simplify" Opt_D_verbose_core2core binds'; - return (counts_out, rule_base', guts { mg_binds = binds' }) + return (counts_out, guts { mg_binds = binds' }) } where - dflags = hsc_dflags hsc_env - phase_info = case mode of - SimplGently -> "gentle" - SimplPhase n -> show n - - sw_chkr = isAmongSimpl switches - max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 + dflags = hsc_dflags hsc_env + phase_info = case mode of + SimplGently -> "gentle" + SimplPhase n -> show n + + sw_chkr = isAmongSimpl switches + max_iterations = intSwitchSet sw_chkr MaxSimplifierIterations `orElse` 2 - do_iteration us rule_base iteration_no counts binds + do_iteration us iteration_no counts binds -- iteration_no is the number of the iteration we are -- about to begin, with '1' for the first | iteration_no > max_iterations -- Stop if we've run out of iterations @@ -438,7 +416,7 @@ simplifyPgm mode switches hsc_env us rule_base guts #endif -- Subtract 1 from iteration_no to get the -- number of iterations we actually completed - return ("Simplifier baled out", iteration_no - 1, counts, rule_base, binds) + return ("Simplifier baled out", iteration_no - 1, counts, binds) } -- Try and force thunks off the binds; significantly reduces @@ -451,20 +429,13 @@ simplifyPgm mode switches hsc_env us rule_base guts (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base - -- (on the side this extends the package rule base in the - -- ExternalPackageTable, ready for the next complation - -- in --make mode) -- We need to do this regularly, because simplification can -- poke on IdInfo thunks, which in turn brings in new rules -- behind the scenes. Otherwise there's a danger we'll simply -- miss the rules for Ids hidden inside imported inlinings - new_rules <- loadImportedRules hsc_env guts ; - let { rule_base' = extendRuleBaseList rule_base new_rules + eps <- hscEPS hsc_env ; + let { rule_base' = unionRuleBase imp_rule_base (eps_rule_base eps) ; simpl_env = mkSimplEnv mode sw_chkr rule_base' } ; - -- The new rule base Ids are used to initialise - -- the in-scope set. That way, the simplifier will change any - -- occurrences of the imported id to the one in the imported_rule_ids - -- set, which are decorated with their rules. -- Simplify the program -- We do this with a *case* not a *let* because lazy pattern @@ -489,7 +460,7 @@ simplifyPgm mode switches hsc_env us rule_base guts -- Stop if nothing happened; don't dump output if isZeroSimplCount counts' then return ("Simplifier reached fixed point", iteration_no, - all_counts, rule_base', binds') + all_counts, binds') else do { -- Short out indirections -- We do this *after* at least one run of the simplifier @@ -504,7 +475,7 @@ simplifyPgm mode switches hsc_env us rule_base guts endPass dflags herald Opt_D_dump_simpl_iterations binds'' ; -- Loop - do_iteration us2 rule_base' (iteration_no + 1) all_counts binds'' + do_iteration us2 (iteration_no + 1) all_counts binds'' } } } } where (us1, us2) = splitUniqSupply us @@ -634,7 +605,7 @@ shortOutIndirections binds ind_env = makeIndEnv binds exp_ids = varSetElems ind_env -- These exported Ids are the subjects exp_id_set = mkVarSet exp_ids -- of the indirection-elimination - no_need_to_flatten = all (null . rulesRules . idSpecialisation) exp_ids + no_need_to_flatten = all (null . specInfoRules . idSpecialisation) exp_ids binds' = concatMap zap binds zap (NonRec bndr rhs) = [NonRec b r | (b,r) <- zapPair (bndr,rhs)] @@ -677,7 +648,7 @@ shortMeOut ind_env exported_id local_id True {- No longer needed - if isEmptyCoreRules (specInfo (idInfo exported_id)) -- Only if no rules + if isEmptySpecInfo (specInfo (idInfo exported_id)) -- Only if no rules then True -- See note on "Messing up rules" else #ifdef DEBUG @@ -697,6 +668,6 @@ transferIdInfo exported_id local_id local_info = idInfo local_id transfer exp_info = exp_info `setNewStrictnessInfo` newStrictnessInfo local_info `setWorkerInfo` workerInfo local_info - `setSpecInfo` addRules exported_id (specInfo exp_info) - (rulesRules (specInfo local_info)) + `setSpecInfo` addSpecInfo (specInfo exp_info) + (specInfo local_info) \end{code} diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index ce0f442512..df56ea7e85 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -42,7 +42,7 @@ import SimplMonad import Id ( Id, idType, idOccInfo, idUnfolding, setIdUnfolding ) import IdInfo ( IdInfo, vanillaIdInfo, occInfo, setOccInfo, specInfo, setSpecInfo, arityInfo, setArityInfo, workerInfo, setWorkerInfo, - unfoldingInfo, setUnfoldingInfo, + unfoldingInfo, setUnfoldingInfo, isEmptySpecInfo, unknownArity, workerExists ) import CoreSyn @@ -52,10 +52,10 @@ import CoreUtils ( needsCaseBinding ) import CostCentre ( CostCentreStack, subsumedCCS ) import Var import VarEnv -import VarSet ( isEmptyVarSet, elemVarSetByKey, mkVarSet ) +import VarSet ( isEmptyVarSet ) import OrdList -import qualified CoreSubst ( Subst, mkSubst, substExpr, substRules, substWorker ) +import qualified CoreSubst ( Subst, mkSubst, substExpr, substSpec, substWorker ) import qualified Type ( substTy, substTyVarBndr ) import Type ( Type, TvSubst(..), TvSubstEnv, composeTvSubst, @@ -563,7 +563,7 @@ substIdInfo env info | nothing_to_do = Nothing | otherwise = Just (info `setOccInfo` (if keep_occ then old_occ else NoOccInfo) `setArityInfo` (if keep_arity then old_arity else unknownArity) - `setSpecInfo` CoreSubst.substRules subst old_rules + `setSpecInfo` CoreSubst.substSpec subst old_rules `setWorkerInfo` CoreSubst.substWorker subst old_wrkr `setUnfoldingInfo` noUnfolding) -- setSpecInfo does a seq @@ -571,7 +571,7 @@ substIdInfo env info where subst = mkCoreSubst env nothing_to_do = keep_occ && keep_arity && - isEmptyCoreRules old_rules && + isEmptySpecInfo old_rules && not (workerExists old_wrkr) && not (hasUnfolding (unfoldingInfo info)) diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index e66e048eff..6901821c9f 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -5,32 +5,44 @@ \begin{code} module Rules ( - RuleBase, emptyRuleBase, - extendRuleBaseList, - ruleBaseIds, pprRuleBase, ruleCheckProgram, + RuleBase, emptyRuleBase, mkRuleBase, extendRuleBaseList, + unionRuleBase, pprRuleBase, ruleCheckProgram, - lookupRule, addRule, addRules, addIdSpecialisations + mkSpecInfo, extendSpecInfo, addSpecInfo, + rulesOfBinds, addIdSpecialisations, + + lookupRule, mkLocalRule, roughTopNames ) where #include "HsVersions.h" import CoreSyn -- All of it -import OccurAnal ( occurAnalyseRule ) -import CoreFVs ( exprFreeVars, exprsFreeVars, ruleRhsFreeVars ) +import OccurAnal ( occurAnalyseGlobalExpr ) +import CoreFVs ( exprFreeVars, exprsFreeVars, rulesRhsFreeVars ) import CoreUnfold ( isCheapUnfolding, unfoldingTemplate ) import CoreUtils ( tcEqExprX ) +import PprCore ( pprRules ) import Type ( Type ) -import CoreTidy ( pprTidyIdRules ) -import Id ( Id, idUnfolding, isLocalId, idSpecialisation, setIdSpecialisation ) +import TcType ( tcSplitTyConApp_maybe ) +import CoreTidy ( tidyRules ) +import Id ( Id, idUnfolding, isLocalId, isGlobalId, idName, + idSpecialisation, idCoreRules, setIdSpecialisation ) +import IdInfo ( SpecInfo( SpecInfo ) ) import Var ( Var ) +import VarEnv ( IdEnv, TyVarEnv, InScopeSet, emptyTidyEnv, + emptyInScopeSet, mkInScopeSet, extendInScopeSetList, + emptyVarEnv, lookupVarEnv, extendVarEnv, + nukeRnEnvL, mkRnEnv2, rnOccR, rnOccL, inRnEnvR, + rnBndrR, rnBndr2, rnBndrL, rnBndrs2 ) import VarSet -import VarEnv +import Name ( Name, NamedThing(..), nameOccName ) +import NameEnv import Unify ( tcMatchTyX, MatchEnv(..) ) import BasicTypes ( Activation, CompilerPhase, isActive ) import Outputable import FastString -import Maybe ( isJust, fromMaybe ) +import Maybe ( isJust ) import Bag import List ( isPrefixOf ) \end{code} @@ -70,6 +82,109 @@ might have a specialisation where pi' :: Lift Int# is the specialised version of pi. +\begin{code} +mkLocalRule :: RuleName -> Activation + -> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule +-- Used to make CoreRule for an Id defined in this module +mkLocalRule name act fn bndrs args rhs + = Rule { ru_name = name, ru_fn = fn, ru_act = act, + ru_bndrs = bndrs, ru_args = args, + ru_rhs = rhs, ru_rough = roughTopNames args, + ru_orph = Just (nameOccName fn), ru_local = True } + +-------------- +roughTopNames :: [CoreExpr] -> [Maybe Name] +roughTopNames args = map roughTopName args + +roughTopName :: CoreExpr -> Maybe Name +-- Find the "top" free name of an expression +-- a) the function in an App chain (if a GlobalId) +-- b) the TyCon in a type +-- This is used for the fast-match-check for rules; +-- if the top names don't match, the rest can't +roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (App f a) = roughTopName f +roughTopName (Var f) | isGlobalId f = Just (idName f) + | otherwise = Nothing +roughTopName other = Nothing + +ruleCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (ruleCantMatch tpl actual) returns True only if 'actual' +-- definitely can't match 'tpl' by instantiating 'tpl'. +-- It's only a one-way match; unlike instance matching we +-- don't consider unification +ruleCantMatch (Just n1 : ts) (Just n2 : as) = n1 /= n2 || ruleCantMatch ts as +ruleCantMatch (Just n1 : ts) (Nothing : as) = True +ruleCantMatch (t : ts) (a : as) = ruleCantMatch ts as +ruleCantMatch ts as = False +\end{code} + + +%************************************************************************ +%* * + SpecInfo: the rules in an IdInfo +%* * +%************************************************************************ + +\begin{code} +mkSpecInfo :: [CoreRule] -> SpecInfo +mkSpecInfo rules = SpecInfo rules (rulesRhsFreeVars rules) + +extendSpecInfo :: SpecInfo -> [CoreRule] -> SpecInfo +extendSpecInfo (SpecInfo rs1 fvs1) rs2 + = SpecInfo (rs2 ++ rs1) (rulesRhsFreeVars rs2 `unionVarSet` fvs1) + +addSpecInfo :: SpecInfo -> SpecInfo -> SpecInfo +addSpecInfo (SpecInfo rs1 fvs1) (SpecInfo rs2 fvs2) + = SpecInfo (rs1 ++ rs2) (fvs1 `unionVarSet` fvs2) + +addIdSpecialisations :: Id -> [CoreRule] -> Id +addIdSpecialisations id rules + = setIdSpecialisation id $ + extendSpecInfo (idSpecialisation id) rules + +rulesOfBinds :: [CoreBind] -> [CoreRule] +rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds +\end{code} + + +%************************************************************************ +%* * + RuleBase +%* * +%************************************************************************ + +\begin{code} +type RuleBase = NameEnv [CoreRule] + -- Maps (the name of) an Id to its rules + -- The rules are are unordered; + -- we sort out any overlaps on lookup + +emptyRuleBase = emptyNameEnv + +mkRuleBase :: [CoreRule] -> RuleBase +mkRuleBase rules = extendRuleBaseList emptyRuleBase rules + +extendRuleBaseList :: RuleBase -> [CoreRule] -> RuleBase +extendRuleBaseList rule_base new_guys + = foldl extendRuleBase rule_base new_guys + +unionRuleBase :: RuleBase -> RuleBase -> RuleBase +unionRuleBase rb1 rb2 = plusNameEnv_C (++) rb1 rb2 + +extendRuleBase :: RuleBase -> CoreRule -> RuleBase +extendRuleBase rule_base rule + = extendNameEnv_C add rule_base (ruleIdName rule) [rule] + where + add rules _ = rule : rules + +pprRuleBase :: RuleBase -> SDoc +pprRuleBase rules = vcat [ pprRules (tidyRules emptyTidyEnv rs) + | rs <- nameEnvElts rules ] +\end{code} + %************************************************************************ %* * @@ -78,20 +193,70 @@ where pi' :: Lift Int# is the specialised version of pi. %************************************************************************ \begin{code} +lookupRule :: (Activation -> Bool) -> InScopeSet + -> RuleBase -- Imported rules + -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) +lookupRule is_active in_scope rule_base fn args + = matchRules is_active in_scope fn args rules + where + rules | isLocalId fn = idCoreRules fn + | otherwise = case lookupNameEnv rule_base (idName fn) of + Just rules -> rules + Nothing -> [] + matchRules :: (Activation -> Bool) -> InScopeSet - -> [CoreRule] -> [CoreExpr] -> Maybe (RuleName, CoreExpr) + -> Id -> [CoreExpr] + -> [CoreRule] -> Maybe (RuleName, CoreExpr) -- See comments on matchRule -matchRules is_active in_scope [] args = Nothing -matchRules is_active in_scope (rule:rules) args - = case matchRule is_active in_scope rule args of - Just result -> Just result - Nothing -> matchRules is_active in_scope rules args +matchRules is_active in_scope fn args rules + = case go [] rules of + [] -> Nothing + (m:ms) -> Just (case findBest (fn,args) m ms of + (rule, ans) -> (ru_name rule, ans)) + where + rough_args = map roughTopName args + + go :: [(CoreRule,CoreExpr)] -> [CoreRule] -> [(CoreRule,CoreExpr)] + go ms [] = ms + go ms (r:rs) = case (matchRule is_active in_scope args rough_args r) of + Just e -> go ((r,e):ms) rs + Nothing -> go ms rs + +findBest :: (Id, [CoreExpr]) + -> (CoreRule,CoreExpr) -> [(CoreRule,CoreExpr)] -> (CoreRule,CoreExpr) +-- All these pairs matched the expression +-- Return the pair the the most specific rule +-- The (fn,args) is just for overlap reporting + +findBest target (rule,ans) [] = (rule,ans) +findBest target (rule1,ans1) ((rule2,ans2):prs) + | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs + | rule2 `isMoreSpecific` rule1 = findBest target (rule1,ans1) prs + | otherwise = pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" + (vcat [ptext SLIT("Expression to match:") <+> ppr fn <+> sep (map ppr args), + ptext SLIT("Rule 1:") <+> ppr rule1, + ptext SLIT("Rule 2:") <+> ppr rule2]) $ + findBest target (rule1,ans1) prs + where + (fn,args) = target + +isMoreSpecific :: CoreRule -> CoreRule -> Bool +isMoreSpecific (BuiltinRule {}) r2 = True +isMoreSpecific r1 (BuiltinRule {}) = False +isMoreSpecific (Rule { ru_bndrs = bndrs1, ru_args = args1 }) + (Rule { ru_bndrs = bndrs2, ru_args = args2 }) + = isJust (matchN in_scope bndrs2 args2 args1) + where + in_scope = mkInScopeSet (mkVarSet bndrs1) + -- Actually we should probably include the free vars + -- of rule1's args, but I can't be bothered noBlackList :: Activation -> Bool noBlackList act = False -- Nothing is black listed matchRule :: (Activation -> Bool) -> InScopeSet - -> CoreRule -> [CoreExpr] -> Maybe (RuleName, CoreExpr) + -> [CoreExpr] -> [Maybe Name] + -> CoreRule -> Maybe CoreExpr -- If (matchRule rule args) returns Just (name,rhs) -- then (f args) matches the rule, and the corresponding @@ -115,18 +280,27 @@ matchRule :: (Activation -> Bool) -> InScopeSet -- Any 'surplus' arguments in the input are simply put on the end -- of the output. -matchRule is_active in_scope rule@(BuiltinRule name match_fn) args +matchRule is_active in_scope args rough_args + (BuiltinRule { ru_name = name, ru_try = match_fn }) = case match_fn args of - Just expr -> Just (name,expr) + Just expr -> Just expr Nothing -> Nothing -matchRule is_active in_scope rule@(Rule rn act tpl_vars tpl_args rhs) args - | not (is_active act) - = Nothing +matchRule is_active in_scope args rough_args + (Rule { ru_name = rn, ru_act = act, ru_rough = tpl_tops, + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) + | not (is_active act) = Nothing + | ruleCantMatch tpl_tops rough_args = Nothing | otherwise = case matchN in_scope tpl_vars tpl_args args of - Just (tpl_vals, leftovers) -> Just (rn, mkLams tpl_vars rhs `mkApps` tpl_vals `mkApps` leftovers) Nothing -> Nothing + Just (tpl_vals, leftovers) -> Just (rule_fn + `mkApps` tpl_vals + `mkApps` leftovers) + where + rule_fn = occurAnalyseGlobalExpr (mkLams tpl_vars rhs) + -- We could do this when putting things into the rulebase, I guess \end{code} \begin{code} @@ -342,87 +516,6 @@ match_ty menv (tv_subst, id_subst) ty1 ty2 %************************************************************************ %* * -\subsection{Adding a new rule} -%* * -%************************************************************************ - -\begin{code} -addRules :: Id -> CoreRules -> [CoreRule] -> CoreRules -addRule :: Id -> CoreRules -> CoreRule -> CoreRules - --- Add a new rule to an existing bunch of rules. --- The rules are for the given Id; the Id argument is needed only --- so that we can exclude the Id from its own RHS free-var set - --- Insert the new rule just before a rule that is *less specific* --- than the new one; or at the end if there isn't such a one. --- In this way we make sure that when looking up, the first match --- is the most specific. --- --- We make no check for rules that unify without one dominating --- the other. Arguably this would be a bug. - -addRules id rules rule_list = foldl (addRule id) rules rule_list - -addRule id (Rules rules rhs_fvs) rule@(BuiltinRule _ _) - = Rules (rule:rules) rhs_fvs - -- Put it at the start for lack of anything better - -addRule id (Rules rules rhs_fvs) rule - = Rules (insertRule rules new_rule) (rhs_fvs `unionVarSet` new_rhs_fvs) - where - new_rule = occurAnalyseRule rule - new_rhs_fvs = ruleRhsFreeVars new_rule `delVarSet` id - -- Hack alert! - -- Don't include the Id in its own rhs free-var set. - -- Otherwise the occurrence analyser makes bindings recursive - -- that shoudn't be. E.g. - -- RULE: f (f x y) z ==> f x (f y z) - -insertRule rules new_rule@(Rule _ _ tpl_vars tpl_args _) - = go rules - where - tpl_var_set = mkInScopeSet (mkVarSet tpl_vars) - -- Actually we should probably include the free vars of tpl_args, - -- but I can't be bothered - - go [] = [new_rule] - go (rule:rules) | new_is_more_specific rule = (new_rule:rule:rules) - | otherwise = rule : go rules - - new_is_more_specific rule = isJust (matchRule noBlackList tpl_var_set rule tpl_args) - -addIdSpecialisations :: Id -> [CoreRule] -> Id -addIdSpecialisations id rules - = setIdSpecialisation id new_specs - where - new_specs = addRules id (idSpecialisation id) rules -\end{code} - - -%************************************************************************ -%* * -\subsection{Looking up a rule} -%* * -%************************************************************************ - -\begin{code} -lookupRule :: (Activation -> Bool) - -> InScopeSet - -> RuleBase -- Ids from other modules - -> Id -> [CoreExpr] -> Maybe (RuleName, CoreExpr) -lookupRule is_active in_scope rules fn args - = case idSpecialisation fn' of - Rules rules _ -> matchRules is_active in_scope rules args - where - fn' | isLocalId fn = fn - | Just ext_fn <- lookupVarSet (ruleBaseIds rules) fn = ext_fn - | otherwise = fn -\end{code} - - -%************************************************************************ -%* * \subsection{Checking a program for failing rule applications} %* * %************************************************************************ @@ -487,8 +580,7 @@ ruleCheckFun (phase, pat) fn args | null name_match_rules = emptyBag | otherwise = unitBag (ruleAppCheck_help phase fn args name_match_rules) where - name_match_rules = case idSpecialisation fn of - Rules rules _ -> filter match rules + name_match_rules = filter match (idCoreRules fn) match rule = pat `isPrefixOf` unpackFS (ruleName rule) ruleAppCheck_help :: CompilerPhase -> Id -> [CoreExpr] -> [CoreRule] -> SDoc @@ -499,21 +591,23 @@ ruleAppCheck_help phase fn args rules where n_args = length args i_args = args `zip` [1::Int ..] + rough_args = map roughTopName args check_rule rule = rule_herald rule <> colon <+> rule_info rule - rule_herald (BuiltinRule name _) = - ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name) - rule_herald (Rule name _ _ _ _) = - ptext SLIT("Rule") <+> doubleQuotes (ftext name) + rule_herald (BuiltinRule { ru_name = name }) + = ptext SLIT("Builtin rule") <+> doubleQuotes (ftext name) + rule_herald (Rule { ru_name = name }) + = ptext SLIT("Rule") <+> doubleQuotes (ftext name) rule_info rule - | Just (name,_) <- matchRule noBlackList emptyInScopeSet rule args + | Just _ <- matchRule noBlackList emptyInScopeSet args rough_args rule = text "matches (which is very peculiar!)" - rule_info (BuiltinRule name fn) = text "does not match" + rule_info (BuiltinRule {}) = text "does not match" - rule_info (Rule name act rule_bndrs rule_args _) + rule_info (Rule { ru_name = name, ru_act = act, + ru_bndrs = rule_bndrs, ru_args = rule_args}) | not (isActive phase act) = text "active only in later phase" | n_args < n_rule_args = text "too few arguments" | n_mismatches == n_rule_args = text "no arguments match" @@ -533,39 +627,3 @@ ruleAppCheck_help phase fn args rules , me_tmpls = mkVarSet rule_bndrs } \end{code} - -%************************************************************************ -%* * -\subsection{Getting the rules ready} -%* * -%************************************************************************ - -\begin{code} -data RuleBase = RuleBase - IdSet -- Ids with their rules in their specialisations - -- Held as a set, so that it can simply be the initial - -- in-scope set in the simplifier - -- This representation is a bit cute, and I wonder if we should - -- change it to use (IdEnv CoreRule) which seems a bit more natural - -ruleBaseIds (RuleBase ids) = ids -emptyRuleBase = RuleBase emptyVarSet - -extendRuleBaseList :: RuleBase -> [IdCoreRule] -> RuleBase -extendRuleBaseList rule_base new_guys - = foldl extendRuleBase rule_base new_guys - -extendRuleBase :: RuleBase -> IdCoreRule -> RuleBase -extendRuleBase (RuleBase rule_ids) (IdCoreRule id _ rule) - = RuleBase (extendVarSet rule_ids new_id) - where - new_id = setIdSpecialisation id (addRule id old_rules rule) - old_rules = idSpecialisation (fromMaybe id (lookupVarSet rule_ids id)) - -- Get the old rules from rule_ids if the Id is already there, but - -- if not, use the Id from the incoming rule. If may be a PrimOpId, - -- in which case it may have rules in its belly already. Seems - -- dreadfully hackoid. - -pprRuleBase :: RuleBase -> SDoc -pprRuleBase (RuleBase rules) = vcat [ pprTidyIdRules id | id <- varSetElems rules ] -\end{code} diff --git a/ghc/compiler/specialise/SpecConstr.lhs b/ghc/compiler/specialise/SpecConstr.lhs index b5f3f0eebe..271d59dfd2 100644 --- a/ghc/compiler/specialise/SpecConstr.lhs +++ b/ghc/compiler/specialise/SpecConstr.lhs @@ -14,18 +14,18 @@ import CoreSyn import CoreLint ( showPass, endPass ) import CoreUtils ( exprType, tcEqExpr, mkPiTypes ) import CoreFVs ( exprsFreeVars ) -import CoreTidy ( pprTidyIdRules ) +import CoreTidy ( tidyRules ) +import PprCore ( pprRules ) import WwLib ( mkWorkerArgs ) import DataCon ( dataConRepArity ) import Type ( tyConAppArgs ) -import Id ( Id, idName, idType, - isDataConWorkId_maybe, +import Id ( Id, idName, idType, isDataConWorkId_maybe, mkUserLocal, mkSysLocal ) import Var ( Var ) import VarEnv import VarSet import Name ( nameOccName, nameSrcLoc ) -import Rules ( addIdSpecialisations ) +import Rules ( addIdSpecialisations, mkLocalRule, rulesOfBinds ) import OccName ( mkSpecOcc ) import ErrUtils ( dumpIfSet_dyn ) import DynFlags ( DynFlags, DynFlag(..) ) @@ -182,7 +182,7 @@ specConstrProgram dflags us binds endPass dflags "SpecConstr" Opt_D_dump_spec binds' dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations" - (vcat (map pprTidyIdRules (concat (map bindersOf binds')))) + (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds'))) return binds' where @@ -512,8 +512,8 @@ spec_one env fn rhs (pats, rule_number) rule_name = mkFastString ("SC:" ++ showSDoc (ppr fn <> int rule_number)) spec_rhs = mkLams spec_lam_args spec_body spec_id = mkUserLocal spec_occ spec_uniq (mkPiTypes spec_lam_args body_ty) fn_loc - rule = Rule rule_name specConstrActivation - bndrs pats (mkVarApps (Var spec_id) spec_call_args) + rhs = mkVarApps (Var spec_id) spec_call_args + rule = mkLocalRule rule_name specConstrActivation fn_name bndrs pats rhs in returnUs (rule, (spec_id, spec_rhs)) diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index f276caeb5e..086e7b0954 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -24,10 +24,10 @@ import VarEnv import CoreSyn import CoreUtils ( applyTypeToArgs, mkPiTypes ) import CoreFVs ( exprFreeVars, exprsFreeVars ) -import CoreTidy ( pprTidyIdRules ) +import CoreTidy ( tidyRules ) import CoreLint ( showPass, endPass ) -import Rules ( addIdSpecialisations, lookupRule, emptyRuleBase ) - +import Rules ( addIdSpecialisations, mkLocalRule, lookupRule, emptyRuleBase, rulesOfBinds ) +import PprCore ( pprRules ) import UniqSupply ( UniqSupply, UniqSM, initUs_, thenUs, returnUs, getUniqueUs, getUs, mapUs @@ -586,7 +586,7 @@ specProgram dflags us binds endPass dflags "Specialise" Opt_D_dump_spec binds' dumpIfSet_dyn dflags Opt_D_dump_rules "Top-level specialisations" - (vcat (map pprTidyIdRules (concat (map bindersOf binds')))) + (pprRules (tidyRules emptyTidyEnv (rulesOfBinds binds'))) return binds' where @@ -888,8 +888,8 @@ specDefn subst calls (fn, rhs) let -- The rule to put in the function's specialisation is: -- forall b,d, d1',d2'. f t1 b t3 d d1' d2' = f1 b d - spec_env_rule = Rule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) - AlwaysActive + spec_env_rule = mkLocalRule (mkFastString ("SPEC " ++ showSDoc (ppr fn))) + AlwaysActive (idName fn) (poly_tyvars ++ rhs_dicts') inst_args (mkVarApps (Var spec_f) app_args) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 1be79b2236..8e8e44ae2f 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -7,7 +7,7 @@ module Inst ( Inst, - pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages + pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages tidyInsts, tidyMoreInsts, @@ -23,7 +23,7 @@ module Inst ( instLoc, getDictClassTys, dictPred, lookupInst, LookupInstResult(..), lookupPred, - tcExtendLocalInstEnv, tcGetInstEnvs, + tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag, isDict, isClassDict, isMethod, isLinearInst, linearInstType, isIPDict, isInheritableInst, @@ -49,15 +49,17 @@ import TcHsSyn ( TcId, TcIdSet, ) import TcRnMonad import TcEnv ( tcLookupId, checkWellStaged, topIdLvl, tcMetaTy ) -import InstEnv ( DFunId, InstEnv, lookupInstEnv, checkFunDeps, extendInstEnv ) -import TcIface ( loadImportedInsts ) +import InstEnv ( DFunId, InstEnv, Instance(..), OverlapFlag(..), + lookupInstEnv, extendInstEnv, pprInstances, + instanceHead, instanceDFunId, setInstanceDFunId ) +import FunDeps ( checkFunDeps ) import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType, zonkTcThetaType, tcInstTyVar, tcInstType, tcSkolType ) import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType, - PredType(..), SkolemInfo(..), Expected(..), typeKind, mkSigmaTy, + PredType(..), SkolemInfo(..), typeKind, mkSigmaTy, tcSplitForAllTys, tcSplitForAllTys, mkFunTy, - tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunTy, tcSplitDFunHead, + tcSplitPhiTy, tcIsTyVarTy, tcSplitDFunHead, isIntTy,isFloatTy, isIntegerTy, isDoubleTy, tcIsTyVarTy, mkPredTy, mkTyVarTy, mkTyVarTys, tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tidyPred, @@ -65,7 +67,7 @@ import TcType ( Type, TcType, TcThetaType, TcTyVarSet, TcTyVar, TcPredType, getClassPredTys, getClassPredTys_maybe, mkPredName, isInheritablePred, isIPPred, tidyType, tidyTypes, tidyFreeTyVars, tcSplitSigmaTy, - pprPred, pprParendType, pprThetaArrow, pprTheta, pprClassPred + pprPred, pprParendType, pprTheta ) import Type ( TvSubst, substTy, substTyVar, substTyWith, substTheta, zipTopTvSubst, notElemTvSubst, extendTvSubstList ) @@ -89,7 +91,7 @@ import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rational import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) -import DynFlags( DynFlags ) +import DynFlags ( DynFlag(..), dopt ) import Maybes ( isJust ) import Outputable \end{code} @@ -519,15 +521,6 @@ pprInst m@(Method inst_id id tys theta tau loc) pprInstInFull inst = sep [quotes (pprInst inst), nest 2 (pprInstLoc (instLoc inst))] -pprDFuns :: [DFunId] -> SDoc --- Prints the dfun as an instance declaration -pprDFuns dfuns = vcat [ hang (ppr (getSrcLoc dfun) <> colon) - 2 (ptext SLIT("instance") <+> sep [pprThetaArrow theta, - pprClassPred clas tys]) - | dfun <- dfuns - , let (_, theta, clas, tys) = tcSplitDFunTy (idType dfun) ] - -- Print without the for-all, which the programmer doesn't write - tidyInst :: TidyEnv -> Inst -> Inst tidyInst env (LitInst nm lit ty loc) = LitInst nm lit (tidyType env ty) loc tidyInst env (Dict nm pred loc) = Dict nm (tidyPred env pred) loc @@ -559,21 +552,20 @@ showLIE str %************************************************************************ \begin{code} -tcExtendLocalInstEnv :: [DFunId] -> TcM a -> TcM a +tcExtendLocalInstEnv :: [Instance] -> TcM a -> TcM a -- Add new locally-defined instances tcExtendLocalInstEnv dfuns thing_inside = do { traceDFuns dfuns ; env <- getGblEnv - ; dflags <- getDOpts - ; inst_env' <- foldlM (addInst dflags) (tcg_inst_env env) dfuns + ; inst_env' <- foldlM addLocalInst (tcg_inst_env env) dfuns ; let env' = env { tcg_insts = dfuns ++ tcg_insts env, tcg_inst_env = inst_env' } ; setGblEnv env' thing_inside } -addInst :: DynFlags -> InstEnv -> DFunId -> TcM InstEnv +addLocalInst :: InstEnv -> Instance -> TcM InstEnv -- Check that the proposed new instance is OK, -- and then add it to the home inst env -addInst dflags home_ie dfun +addLocalInst home_ie ispec = do { -- Instantiate the dfun type so that we extend the instance -- envt with completely fresh template variables -- This is important because the template variables must @@ -581,51 +573,67 @@ addInst dflags home_ie dfun -- (since we do unification). -- We use tcSkolType because we don't want to allocate fresh -- *meta* type variables. - (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun) + let dfun = instanceDFunId ispec + ; (tvs', theta', tau') <- tcSkolType (InstSkol dfun) (idType dfun) ; let (cls, tys') = tcSplitDFunHead tau' dfun' = setIdType dfun (mkSigmaTy tvs' theta' tau') + ispec' = setInstanceDFunId ispec dfun' -- Load imported instances, so that we report -- duplicates correctly - ; pkg_ie <- loadImportedInsts cls tys' + ; eps <- getEps + ; let inst_envs = (eps_inst_env eps, home_ie) -- Check functional dependencies - ; case checkFunDeps (pkg_ie, home_ie) dfun' of - Just dfuns -> funDepErr dfun dfuns + ; case checkFunDeps inst_envs ispec' of + Just specs -> funDepErr ispec' specs Nothing -> return () -- Check for duplicate instance decls - ; let { (matches, _) = lookupInstEnv dflags (pkg_ie, home_ie) cls tys' - ; dup_dfuns = [dup_dfun | (_, (_, dup_tys, dup_dfun)) <- matches, - isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } - -- Find memebers of the match list which - -- dfun itself matches. If the match is 2-way, it's a duplicate - ; case dup_dfuns of - dup_dfun : _ -> dupInstErr dfun dup_dfun - [] -> return () + ; let { (matches, _) = lookupInstEnv inst_envs cls tys' + ; dup_ispecs = [ dup_ispec + | (_, dup_ispec) <- matches + , let (_,_,_,dup_tys) = instanceHead dup_ispec + , isJust (tcMatchTys (mkVarSet tvs') tys' dup_tys)] } + -- Find memebers of the match list which ispec itself matches. + -- If the match is 2-way, it's a duplicate + ; case dup_ispecs of + dup_ispec : _ -> dupInstErr ispec' dup_ispec + [] -> return () -- OK, now extend the envt - ; return (extendInstEnv home_ie dfun') } - - -traceDFuns dfuns - = traceTc (text "Adding instances:" <+> vcat (map pp dfuns)) + ; return (extendInstEnv home_ie ispec') } + +getOverlapFlag :: TcM OverlapFlag +getOverlapFlag + = do { dflags <- getDOpts + ; let overlap_ok = dopt Opt_AllowOverlappingInstances dflags + incoherent_ok = dopt Opt_AllowIncoherentInstances dflags + overlap_flag | incoherent_ok = Incoherent + | overlap_ok = OverlapOk + | otherwise = NoOverlap + + ; return overlap_flag } + +traceDFuns ispecs + = traceTc (hang (text "Adding instances:") 2 (vcat (map pp ispecs))) where - pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) + pp ispec = ppr (instanceDFunId ispec) <+> colon <+> ppr ispec + -- Print the dfun name itself too -funDepErr dfun dfuns - = addDictLoc dfun $ +funDepErr ispec ispecs + = addDictLoc ispec $ addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:")) - 2 (pprDFuns (dfun:dfuns))) -dupInstErr dfun dup_dfun - = addDictLoc dfun $ + 2 (pprInstances (ispec:ispecs))) +dupInstErr ispec dup_ispec + = addDictLoc ispec $ addErr (hang (ptext SLIT("Duplicate instance declarations:")) - 2 (pprDFuns [dfun, dup_dfun])) + 2 (pprInstances [ispec, dup_ispec])) -addDictLoc dfun thing_inside +addDictLoc ispec thing_inside = setSrcSpan (mkSrcSpan loc loc) thing_inside where - loc = getSrcLoc dfun + loc = getSrcLoc ispec \end{code} @@ -738,13 +746,13 @@ lookupInst (Dict _ pred loc) lookupPred :: TcPredType -> TcM (Maybe (TvSubst, DFunId)) -- Look up a class constraint in the instance environment lookupPred pred@(ClassP clas tys) - = do { pkg_ie <- loadImportedInsts clas tys - -- Suck in any instance decls that may be relevant + = do { eps <- getEps ; tcg_env <- getGblEnv - ; dflags <- getDOpts - ; case lookupInstEnv dflags (pkg_ie, tcg_inst_env tcg_env) clas tys of { - ([(tenv, (_,_,dfun_id))], []) - -> do { traceTc (text "lookupInst success" <+> + ; let inst_envs = (eps_inst_env eps, tcg_inst_env tcg_env) + ; case lookupInstEnv inst_envs clas tys of { + ([(tenv, ispec)], []) + -> do { let dfun_id = is_dfun ispec + ; traceTc (text "lookupInst success" <+> vcat [text "dict" <+> ppr pred, text "witness" <+> ppr dfun_id <+> ppr (idType dfun_id) ]) @@ -771,7 +779,8 @@ record_dfun_usage dfun_id = do { dflags <- getDOpts ; let dfun_name = idName dfun_id dfun_mod = nameModule dfun_name - ; if isInternalName dfun_name || not (isHomeModule dflags dfun_mod) + ; if isInternalName dfun_name || -- Internal name => defined in this module + not (isHomeModule dflags dfun_mod) then return () -- internal, or in another package else do { tcg_env <- getGblEnv ; updMutVar (tcg_inst_uses tcg_env) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index ed211b362c..c16e681d6f 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -17,8 +17,8 @@ import BasicTypes ( RecFlag(..) ) import RnHsSyn ( maybeGenericMatch, extractHsTyVars ) import RnExpr ( rnLExpr ) import RnEnv ( lookupTopBndrRn, lookupImportedName ) - -import Inst ( instToId, newDicts, newDictsAtLoc, newMethod ) +import Inst ( instToId, newDicts, newDictsAtLoc, newMethod, getOverlapFlag ) +import InstEnv ( Instance, mkLocalInstance ) import TcEnv ( tcLookupLocatedClass, tcExtendIdEnv2, tcExtendTyVarEnv, InstInfo(..), pprInstInfoDetails, @@ -738,13 +738,14 @@ mkGenericInstance clas (hs_ty, binds) -- Make the dictionary function. getSrcSpanM `thenM` \ span -> + getOverlapFlag `thenM` \ overlap_flag -> newDFunName clas [inst_ty] (srcSpanStart span) `thenM` \ dfun_name -> let inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] + ispec = mkLocalInstance dfun_id overlap_flag in - - returnM (InstInfo { iDFunId = dfun_id, iBinds = VanillaInst binds [] }) + returnM (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] }) \end{code} @@ -806,7 +807,7 @@ dupGenericInsts tc_inst_infos ptext SLIT("All the type patterns for a generic type constructor must be identical") ] where - ppr_inst_ty (tc,inst) = ppr tc <+> ppr (simpleInstInfoTy inst) + ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) mixedGenericErr op = ptext SLIT("Can't mix generic and non-generic equations for class method") <+> quotes (ppr op) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 703d3a840a..2a07925f2f 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -16,17 +16,18 @@ import DynFlags ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) import TcRnMonad import TcEnv ( newDFunName, pprInstInfoDetails, - InstInfo(..), InstBindings(..), + InstInfo(..), InstBindings(..), simpleInstInfoClsTy, tcLookupClass, tcLookupTyCon, tcExtendTyVarEnv ) import TcGenDeriv -- Deriv stuff -import InstEnv ( simpleDFunClassTyCon, extendInstEnvList ) +import InstEnv ( Instance, OverlapFlag, mkLocalInstance, instanceHead, extendInstEnvList ) +import Inst ( getOverlapFlag ) import TcHsType ( tcHsDeriv ) import TcSimplify ( tcSimplifyDeriv ) import RnBinds ( rnMethodBinds, rnTopBinds ) import RnEnv ( bindLocalNames ) -import HscTypes ( DFunId, FixityEnv ) +import HscTypes ( FixityEnv ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) import Type ( zipOpenTvSubst, substTheta ) @@ -44,8 +45,8 @@ import TyCon ( tyConTyVars, tyConDataCons, tyConArity, tyConHasGenerics, ) import TcType ( TcType, ThetaType, mkTyVarTys, mkTyConApp, tcTyConAppTyCon, isUnLiftedType, mkClassPred, tyVarsOfTypes, isArgTypeKind, - tcEqTypes, tcSplitAppTys, mkAppTys, tcSplitDFunTy ) -import Var ( TyVar, tyVarKind, idType, varName ) + tcEqTypes, tcSplitAppTys, mkAppTys ) +import Var ( TyVar, tyVarKind, varName ) import VarSet ( mkVarSet, subVarSet ) import PrelNames import SrcLoc ( srcLocSpan, Located(..) ) @@ -211,15 +212,16 @@ tcDeriving tycl_decls = recoverM (returnM ([], [])) $ do { -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". - ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls + overlap_flag <- getOverlapFlag + ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns overlap_flag tycl_decls ; (ordinary_inst_info, deriv_binds) - <- extendLocalInstEnv (map iDFunId newtype_inst_info) $ - deriveOrdinaryStuff ordinary_eqns + <- extendLocalInstEnv (map iSpec newtype_inst_info) $ + deriveOrdinaryStuff overlap_flag ordinary_eqns -- Add the newtype-derived instances to the inst env -- before tacking the "ordinary" ones - ; let inst_info = newtype_inst_info ++ ordinary_inst_info + ; let inst_info = newtype_inst_info ++ ordinary_inst_info -- If we are compiling a hs-boot file, -- don't generate any derived bindings @@ -256,22 +258,22 @@ tcDeriving tycl_decls = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds) ----------------------------------------- -deriveOrdinaryStuff [] -- Short cut +deriveOrdinaryStuff overlap_flag [] -- Short cut = returnM ([], emptyLHsBinds) -deriveOrdinaryStuff eqns +deriveOrdinaryStuff overlap_flag eqns = do { -- Take the equation list and solve it, to deliver a list of -- solutions, a.k.a. the contexts for the instance decls -- required for the corresponding equations. - ; new_dfuns <- solveDerivEqns eqns + inst_specs <- solveDerivEqns overlap_flag eqns -- Generate the InstInfo for each dfun, -- plus any auxiliary bindings it needs - ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst new_dfuns + ; (inst_infos, aux_binds_s) <- mapAndUnzipM genInst inst_specs -- Generate any extra not-one-inst-decl-specific binds, -- notably "con2tag" and/or "tag2con" functions. - ; extra_binds <- genTaggeryBinds new_dfuns + ; extra_binds <- genTaggeryBinds inst_infos -- Done ; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s)) @@ -311,11 +313,12 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: [LTyClDecl Name] +makeDerivEqns :: OverlapFlag + -> [LTyClDecl Name] -> TcM ([DerivEqn], -- Ordinary derivings [InstInfo]) -- Special newtype derivings -makeDerivEqns tycl_decls +makeDerivEqns overlap_flag tycl_decls = mapAndUnzipM mk_eqn derive_these `thenM` \ (maybe_ordinaries, maybe_newtypes) -> returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where @@ -358,7 +361,7 @@ makeDerivEqns tycl_decls = -- Go ahead and use the isomorphism traceTc (text "newtype deriving:" <+> ppr tycon <+> ppr rep_tys) `thenM_` new_dfun_name clas tycon `thenM` \ dfun_name -> - returnM (Nothing, Just (InstInfo { iDFunId = mk_dfun dfun_name, + returnM (Nothing, Just (InstInfo { iSpec = mk_inst_spec dfun_name, iBinds = NewTypeDerived rep_tys })) | std_class gla_exts clas = mk_eqn_help gla_exts DataType tycon deriv_tvs clas tys -- Go via bale-out route @@ -451,7 +454,10 @@ makeDerivEqns tycl_decls | otherwise = rep_pred : sc_theta -- Finally! Here's where we build the dictionary Id - mk_dfun dfun_name = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys + mk_inst_spec dfun_name + = mkLocalInstance dfun overlap_flag + where + dfun = mkDictFunId dfun_name dict_tvs dict_args clas inst_tys ------------------------------------------------------------------- -- Figuring out whether we can only do this newtype-deriving thing @@ -675,11 +681,12 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \end{itemize} \begin{code} -solveDerivEqns :: [DerivEqn] - -> TcM [DFunId] -- Solns in same order as eqns. +solveDerivEqns :: OverlapFlag + -> [DerivEqn] + -> TcM [Instance]-- Solns in same order as eqns. -- This bunch is Absolutely minimal... -solveDerivEqns orig_eqns +solveDerivEqns overlap_flag orig_eqns = iterateDeriv 1 initial_solutions where -- The initial solutions for the equations claim that each @@ -693,7 +700,7 @@ solveDerivEqns orig_eqns -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. -- It fails if any iteration fails - iterateDeriv :: Int -> [DerivSoln] ->TcM [DFunId] + iterateDeriv :: Int -> [DerivSoln] -> TcM [Instance] iterateDeriv n current_solns | n > 20 -- Looks as if we are in an infinite loop -- This can happen if we have -fallow-undecidable-instances @@ -702,33 +709,36 @@ solveDerivEqns orig_eqns (vcat (map pprDerivEqn orig_eqns) $$ ppr current_solns) | otherwise = let - dfuns = zipWithEqual "add_solns" mk_deriv_dfun orig_eqns current_solns + inst_specs = zipWithEqual "add_solns" mk_inst_spec + orig_eqns current_solns in checkNoErrs ( -- Extend the inst info from the explicit instance decls -- with the current set of solutions, and simplify each RHS - extendLocalInstEnv dfuns $ + extendLocalInstEnv inst_specs $ mappM gen_soln orig_eqns ) `thenM` \ new_solns -> if (current_solns == new_solns) then - returnM dfuns + returnM inst_specs else iterateDeriv (n+1) new_solns ------------------------------------------------------------------ - gen_soln (_, clas, tc,tyvars,deriv_rhs) = setSrcSpan (srcLocSpan (getSrcLoc tc)) $ addErrCtxt (derivCtxt (Just clas) tc) $ tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta -> returnM (sortLe (<=) theta) -- Canonicalise before returning the soluction -mk_deriv_dfun (dfun_name, clas, tycon, tyvars, _) theta - = mkDictFunId dfun_name tyvars theta - clas [mkTyConApp tycon (mkTyVarTys tyvars)] - -extendLocalInstEnv :: [DFunId] -> TcM a -> TcM a --- Add new locall-defined instances; don't bother to check + ------------------------------------------------------------------ + mk_inst_spec (dfun_name, clas, tycon, tyvars, _) theta + = mkLocalInstance dfun overlap_flag + where + dfun = mkDictFunId dfun_name tyvars theta clas + [mkTyConApp tycon (mkTyVarTys tyvars)] + +extendLocalInstEnv :: [Instance] -> TcM a -> TcM a +-- Add new locally-defined instances; don't bother to check -- for functional dependency errors -- that'll happen in TcInstDcls extendLocalInstEnv dfuns thing_inside = do { env <- getGblEnv @@ -802,23 +812,25 @@ the renamer. What a great hack! \begin{code} -- Generate the InstInfo for the required instance, -- plus any auxiliary bindings required -genInst :: DFunId -> TcM (InstInfo, LHsBinds RdrName) -genInst dfun - = getFixityEnv `thenM` \ fix_env -> - let - (tyvars,_,clas,[ty]) = tcSplitDFunTy (idType dfun) - clas_nm = className clas - tycon = tcTyConAppTyCon ty - (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon - in +genInst :: Instance -> TcM (InstInfo, LHsBinds RdrName) +genInst spec + = do { fix_env <- getFixityEnv + ; let + (tyvars,_,clas,[ty]) = instanceHead spec + clas_nm = className clas + tycon = tcTyConAppTyCon ty + (meth_binds, aux_binds) = genDerivBinds clas fix_env tycon + -- Bring the right type variables into -- scope, and rename the method binds - bindLocalNames (map varName tyvars) $ - rnMethodBinds clas_nm [] meth_binds `thenM` \ (rn_meth_binds, _fvs) -> + ; (rn_meth_binds, _fvs) <- bindLocalNames (map varName tyvars) $ + rnMethodBinds clas_nm [] meth_binds -- Build the InstInfo - returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, - aux_binds) + ; return (InstInfo { iSpec = spec, + iBinds = VanillaInst rn_meth_binds [] }, + aux_binds) + } genDerivBinds clas fix_env tycon | className clas `elem` typeableClassNames @@ -881,13 +893,15 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -genTaggeryBinds :: [DFunId] -> TcM (LHsBinds RdrName) -genTaggeryBinds dfuns +genTaggeryBinds :: [InstInfo] -> TcM (LHsBinds RdrName) +genTaggeryBinds infos = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) } where - all_CTs = map simpleDFunClassTyCon dfuns + all_CTs = [ (cls, tcTyConAppTyCon ty) + | info <- infos, + let (cls,ty) = simpleInstInfoClsTy info ] all_tycons = map snd all_CTs (tycons_of_interest, _) = removeDups compare all_tycons diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 8caa51d9cd..e825223f1a 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -3,8 +3,8 @@ module TcEnv( TyThing(..), TcTyThing(..), TcId, -- Instance environment, and InstInfo type - InstInfo(..), pprInstInfo, pprInstInfoDetails, - simpleInstInfoTy, simpleInstInfoTyCon, + InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails, + simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon, InstBindings(..), -- Global environment @@ -44,11 +44,12 @@ module TcEnv( import HsSyn ( LRuleDecl, LHsBinds, LSig, pprLHsBinds ) import TcIface ( tcImportDecl ) +import IfaceEnv ( newGlobalBinder ) import TcRnTypes ( pprTcTyThingCategory ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVarsAndFV ) import TcType ( Type, TcKind, TcTyVar, TcTyVarSet, TcType, - tyVarsOfType, tyVarsOfTypes, tcSplitDFunTy, mkGenTyConApp, + tyVarsOfType, tyVarsOfTypes, mkGenTyConApp, getDFunTyKey, tcTyConAppTyCon, tcGetTyVar, mkTyVarTy, tidyOpenType ) @@ -58,13 +59,14 @@ import Var ( TyVar, Id, idType, tyVarName ) import VarSet import VarEnv import RdrName ( extendLocalRdrEnv ) +import InstEnv ( Instance, DFunId, instanceDFunId, instanceHead ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom ) import NameEnv import OccName ( mkDFunOcc, occNameString ) -import HscTypes ( DFunId, extendTypeEnvList, lookupType, +import HscTypes ( extendTypeEnvList, lookupType, TyThing(..), tyThingId, tyThingDataCon, ExternalPackageState(..) ) @@ -105,9 +107,7 @@ tcLookupGlobal name Just thing -> return thing Nothing -> tcImportDecl name }} -\end{code} -\begin{code} tcLookupGlobalId :: Name -> TcM Id -- Never used for Haskell-source DataCons, hence no ADataCon case tcLookupGlobalId name @@ -490,20 +490,20 @@ newLocalName name -- Make a clone returnM (mkInternalName uniq (getOccName name) (getSrcLoc name)) \end{code} -Make a name for the dict fun for an instance decl. It's a *local* -name for the moment. The CoreTidy pass will externalise it. Even in ---make and ghci stuff, we rebuild the instance environment each time, -so the dfun id is internal to begin with, and external when compiling -other modules +Make a name for the dict fun for an instance decl. It's an *external* +name, like otber top-level names, and hence must be made with newGlobalBinder. \begin{code} newDFunName :: Class -> [Type] -> SrcLoc -> TcM Name newDFunName clas (ty:_) loc - = do { uniq <- newUnique - ; return (mkInternalName uniq (mkDFunOcc dfun_string) loc) } - where - -- Any string that is somewhat unique will do - dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) + = do { index <- nextDFunIndex + ; is_boot <- tcIsHsBoot + ; mod <- getModule + ; let info_string = occNameString (getOccName clas) ++ + occNameString (getDFunTyKey ty) + dfun_occ = mkDFunOcc info_string is_boot index + + ; newGlobalBinder mod dfun_occ Nothing loc } newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc) \end{code} @@ -528,10 +528,13 @@ as well as explicit user written ones. \begin{code} data InstInfo = InstInfo { - iDFunId :: DFunId, -- The dfun id. Its forall'd type variables - iBinds :: InstBindings -- scope over the stuff in InstBindings! + iSpec :: Instance, -- Includes the dfun id. Its forall'd type + iBinds :: InstBindings -- variables scope over the stuff in InstBindings! } +iDFunId :: InstInfo -> DFunId +iDFunId info = instanceDFunId (iSpec info) + data InstBindings = VanillaInst -- The normal case (LHsBinds Name) -- Bindings @@ -551,9 +554,12 @@ pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info)) details (VanillaInst b _) = pprLHsBinds b details (NewTypeDerived _) = text "Derived from the representation type" +simpleInstInfoClsTy :: InstInfo -> (Class, Type) +simpleInstInfoClsTy info = case instanceHead (iSpec info) of + (_, _, cls, [ty]) -> (cls, ty) + simpleInstInfoTy :: InstInfo -> Type -simpleInstInfoTy info = case tcSplitDFunTy (idType (iDFunId info)) of - (_, _, _, [ty]) -> ty +simpleInstInfoTy info = snd (simpleInstInfoClsTy info) simpleInstInfoTyCon :: InstInfo -> TyCon -- Gets the type constructor for a simple instance declaration, diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 37084365ec..74abd23082 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -88,7 +88,7 @@ tcCheckSigma :: LHsExpr Name -- Expession to type check -> TcM (LHsExpr TcId) -- Generalised expr with expected type tcCheckSigma expr expected_ty - = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_` + = -- traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_` tc_expr' expr expected_ty tc_expr' expr sigma_ty diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index bc2db2c5d4..d10e3c0deb 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -608,8 +608,6 @@ zonkStmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s ; (env2, ss') <- zonkStmts env1 ss ; return (env2, s' : ss') } -get (ZonkEnv _ env) = env - zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) zonkStmt env (ParStmt stmts_w_bndrs) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 66868990a0..ebb97b3081 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -28,7 +28,7 @@ import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, HsBang, getBangStrictness, collectSigTysFromHsBinds ) import RnHsSyn ( extractHsTyVars ) import TcRnMonad -import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookup, tcLookupClass, tcLookupTyCon, TyThing(..), getInLocalScope, wrongThingErr ) @@ -36,6 +36,7 @@ import TcMType ( newKindVar, newMetaTyVar, zonkTcKindToKind, checkValidType, UserTypeCtxt(..), pprHsSigCtxt ) import TcUnify ( unifyFunKind, checkExpectedKind ) +import TcIface ( checkWiredInTyCon ) import TcType ( Type, PredType(..), ThetaType, MetaDetails(Flexi), hoistForAllTys, TcType, TcTyVar, TcKind, TcThetaType, TcTauType, @@ -51,7 +52,7 @@ import Name ( Name, mkInternalName ) import OccName ( mkOccName, tvName ) import NameSet import PrelNames ( genUnitTyConName ) -import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy ) +import TysWiredIn ( mkListTy, listTyCon, mkPArrTy, parrTyCon, tupleTyCon ) import Bag ( bagToList ) import BasicTypes ( Boxity(..) ) import SrcLoc ( Located(..), unLoc, noLoc, srcSpanStart ) @@ -443,16 +444,21 @@ ds_type (HsKindSig ty k) = dsHsType ty -- Kind checking done already ds_type (HsListTy ty) - = dsHsType ty `thenM` \ tau_ty -> + = dsHsType ty `thenM` \ tau_ty -> + checkWiredInTyCon listTyCon `thenM_` returnM (mkListTy tau_ty) ds_type (HsPArrTy ty) - = dsHsType ty `thenM` \ tau_ty -> + = dsHsType ty `thenM` \ tau_ty -> + checkWiredInTyCon parrTyCon `thenM_` returnM (mkPArrTy tau_ty) ds_type (HsTupleTy boxity tys) - = dsHsTypes tys `thenM` \ tau_tys -> - returnM (mkTupleTy boxity (length tys) tau_tys) + = dsHsTypes tys `thenM` \ tau_tys -> + checkWiredInTyCon tycon `thenM_` + returnM (mkTyConApp tycon tau_tys) + where + tycon = tupleTyCon boxity (length tys) ds_type (HsFunTy ty1 ty2) = dsHsType ty1 `thenM` \ tau_ty1 -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index c3772615a3..6fdc327be6 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -18,7 +18,9 @@ import TcMType ( tcSkolSigType, checkValidTheta, checkValidInstHead, instTypeEr import TcType ( mkClassPred, tyVarsOfType, tcSplitSigmaTy, tcSplitDFunHead, mkTyVarTys, SkolemInfo(InstSkol), tcSplitDFunTy, pprClassPred ) -import Inst ( tcInstClassOp, newDicts, instToId, showLIE, tcExtendLocalInstEnv ) +import Inst ( tcInstClassOp, newDicts, instToId, showLIE, + getOverlapFlag, tcExtendLocalInstEnv ) +import InstEnv ( mkLocalInstance, instanceDFunId ) import TcDeriv ( tcDeriving ) import TcEnv ( tcExtendGlobalValEnv, tcExtendTyVarEnv, InstInfo(..), InstBindings(..), @@ -148,7 +150,7 @@ tcInstDecls1 tycl_decls inst_decls clas_decls = filter (isClassDecl.unLoc) tycl_decls in -- (2) Instances from generic class declarations - getGenericInstances clas_decls `thenM` \ generic_inst_info -> + getGenericInstances clas_decls `thenM` \ generic_inst_info -> -- Next, construct the instance environment so far, consisting of -- a) local instance decls @@ -169,7 +171,7 @@ tcInstDecls1 tycl_decls inst_decls addInsts :: [InstInfo] -> TcM a -> TcM a addInsts infos thing_inside - = tcExtendLocalInstEnv (map iDFunId infos) thing_inside + = tcExtendLocalInstEnv (map iSpec infos) thing_inside \end{code} \begin{code} @@ -202,8 +204,11 @@ tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) checkTc (checkInstFDs theta clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_` newDFunName clas inst_tys (srcSpanStart loc) `thenM` \ dfun_name -> - returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys, - iBinds = VanillaInst binds uprags })) + getOverlapFlag `thenM` \ overlap_flag -> + let dfun = mkDictFunId dfun_name tyvars theta clas inst_tys + ispec = mkLocalInstance dfun overlap_flag + in + returnM (Just (InstInfo { iSpec = ispec, iBinds = VanillaInst binds uprags })) where msg = parens (ptext SLIT("the instance types do not agree with the functional dependencies of the class")) \end{code} @@ -308,17 +313,18 @@ First comes the easy case of a non-local instance decl. \begin{code} tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) -tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) - = -- Prime error recovery +tcInstDecl2 (InstInfo { iSpec = ispec, iBinds = binds }) + = let + dfun_id = instanceDFunId ispec + rigid_info = InstSkol dfun_id + inst_ty = idType dfun_id + in + -- Prime error recovery recoverM (returnM emptyLHsBinds) $ setSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ -- Instantiate the instance decl with skolem constants - let - rigid_info = InstSkol dfun_id - inst_ty = idType dfun_id - in tcSkolSigType rigid_info inst_ty `thenM` \ (inst_tyvars', dfun_theta', inst_head') -> -- These inst_tyvars' scope over the 'where' part -- Those tyvars are inside the dfun_id's type, which is a bit diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index f5bf84c3e3..ef817f3f8b 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -28,7 +28,7 @@ import StaticFlags ( opt_PprStyle_Debug ) import Packages ( moduleToPackageConfig, mkPackageId, package, isHomeModule ) import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, - SpliceDecl(..), HsBind(..), + SpliceDecl(..), HsBind(..), LHsBinds, emptyGroup, appendGroups, nlHsApp, nlHsVar, pprLHsBinds ) import RdrHsSyn ( findSplice ) @@ -42,7 +42,7 @@ import TcExpr ( tcInferRho ) import TcRnMonad import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) import Inst ( showLIE ) -import InstEnv ( extendInstEnvList ) +import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, iDFunId ) @@ -57,11 +57,11 @@ import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, reportUnusedNames, reportDeprecations ) import RnEnv ( lookupSrcOcc_maybe ) import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) -import PprCore ( pprIdRules, pprCoreBindings ) -import CoreSyn ( IdCoreRule, bindersOfBinds ) +import PprCore ( pprRules, pprCoreBindings ) +import CoreSyn ( CoreRule, bindersOfBinds ) import DataCon ( dataConWrapId ) import ErrUtils ( Messages, mkDumpDoc, showPass ) -import Id ( mkExportedLocalId, isLocalId, idName, idType ) +import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) import Var ( Var ) import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv ) import OccName ( mkVarOcc ) @@ -107,7 +107,7 @@ import RnExpr ( rnStmts, rnLExpr ) import LoadIface ( loadSrcInterface, ifaceInstGates ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), IfaceConDecls(..), IfaceInst(..), - tyThingToIfaceDecl, dfunToIfaceInst ) + tyThingToIfaceDecl, instanceToIfaceInst ) import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType, interactiveExtNameFun, isLocalIfaceExtName ) import IfaceEnv ( lookupOrig, ifaceExportNames ) @@ -130,7 +130,6 @@ import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnv availNames, availName, ModIface(..), icPrintUnqual, ModDetails(..), Dependencies(..) ) import BasicTypes ( RecFlag(..), Fixity ) -import Bag ( unitBag ) import ListSetOps ( removeDups ) import Panic ( ghcError, GhcException(..) ) import SrcLoc ( SrcLoc ) @@ -138,7 +137,7 @@ import SrcLoc ( SrcLoc ) import FastString ( mkFastString ) import Util ( sortLe ) -import Bag ( unionBags, snocBag ) +import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) import Maybe ( isJust ) \end{code} @@ -398,16 +397,17 @@ tcRnSrcDecls decls let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_type_env = final_type_env, - tcg_binds = binds', tcg_rules = rules', + tcg_binds = binds', + tcg_rules = rules', tcg_fords = fords' } } ; - -- Compare the hi-boot iface (if any) with the real thing - checkHiBootIface tcg_env' boot_iface ; - -- Make the new type env available to stuff slurped from interface files writeMutVar (tcg_type_env_var tcg_env) final_type_env ; - return tcg_env' + -- Compare the hi-boot iface (if any) with the real thing + dfun_binds <- checkHiBootIface tcg_env' boot_iface ; + + return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -510,23 +510,25 @@ spliceInHsBootErr (SpliceDecl (L loc _), _) = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files")) \end{code} -In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded -into the External Package Table. Once we've typechecked the body of the -module, we want to compare what we've found (gathered in a TypeEnv) with -the hi-boot stuff in the EPT. We do so here, using the export list of -the hi-boot interface as our checklist. +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). \begin{code} -checkHiBootIface :: TcGblEnv -> ModDetails -> TcM () +checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- Compare the hi-boot file for this module (if there is one) -- with the type environment we've just come up with -- In the common case where there is no hi-boot file, the list -- of boot_names is empty. +-- +-- The bindings we return give bindings for the dfuns defined in the +-- hs-boot file, such as $fbEqT = $fEqT + checkHiBootIface (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) - = do { mapM_ check_inst boot_insts - ; mapM_ check_one (typeEnvElts boot_type_env) } + = do { mapM_ check_one (typeEnvElts boot_type_env) + ; dfun_binds <- mapM check_inst boot_insts + ; return (unionManyBags dfun_binds) } where check_one boot_thing | no_check name @@ -544,11 +546,15 @@ checkHiBootIface || name `elem` dfun_names dfun_names = map getName boot_insts - check_inst inst - | null [i | i <- local_insts, idType i `tcEqType` idType inst] - = addErrTc (instMisMatch inst) - | otherwise - = return () + check_inst boot_inst + = case [dfun | inst <- local_insts, + let dfun = instanceDFunId inst, + idType dfun `tcEqType` boot_inst_ty ] of + [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag } + (dfun:_) -> return (unitBag $ noLoc $ VarBind boot_dfun (nlHsVar dfun)) + where + boot_dfun = instanceDFunId boot_inst + boot_inst_ty = idType boot_dfun ---------------- check_thing (ATyCon boot_tc) (ATyCon real_tc) @@ -582,7 +588,7 @@ missingBootThing thing bootMisMatch thing = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") instMisMatch inst - = hang (ptext SLIT("instance") <+> ppr (idType inst)) + = hang (ptext SLIT("instance") <+> ppr inst) 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) \end{code} @@ -1135,8 +1141,8 @@ getModuleContents hsc_env mod exports_only --------------------- filter_decl occs decl@(IfaceClass {ifSigs = sigs}) = decl { ifSigs = filter (keep_sig occs) sigs } -filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons}) - = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) } +filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons}) + = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) } filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con}) | keep_con occs con = decl | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm? @@ -1226,10 +1232,11 @@ tcRnGetInfo hsc_env ictxt rdr_name -- their parent declaration let { do_one name = do { thing <- tcLookupGlobal name ; fixity <- lookupFixityRn name - ; dfuns <- lookupInsts ext_nm thing + ; ispecs <- lookupInsts ext_nm thing ; return (str, toIfaceDecl ext_nm thing, fixity, getSrcLoc thing, - [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns] + [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) + | dfun <- map instanceDFunId ispecs ] ) } where -- str is the the naked occurrence name @@ -1249,15 +1256,15 @@ tcRnGetInfo hsc_env ictxt rdr_name ext_nm = interactiveExtNameFun (icPrintUnqual ictxt) -lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId] +lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [Instance] -- Filter the instances by the ones whose tycons (or clases resp) -- are in scope unqualified. Otherwise we list a whole lot too many! lookupInsts ext_nm (AClass cls) = do { loadImportedInsts cls [] -- [] means load all instances for cls ; inst_envs <- tcGetInstEnvs - ; return [ dfun - | (_,_,dfun) <- classInstances inst_envs cls - , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun)) + ; return [ ispec + | ispec <- classInstances inst_envs cls + , let (_, tycons) = ifaceInstGates (ifInstHead (instanceToIfaceInst ext_nm ispec)) -- Rather an indirect/inefficient test, but there we go , all print_tycon_unqual tycons ] } where @@ -1275,10 +1282,10 @@ lookupInsts ext_nm (ATyCon tc) ; return [ dfun | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie , relevant dfun - , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun)) + , let (cls, _) = ifaceInstGates (ifInstHead (instanceToIfaceInst ext_nm dfun)) , isLocalIfaceExtName cls ] } where - relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) + relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType (instanceDFunId df)) tc_name = tyConName tc lookupInsts ext_nm other = return [] @@ -1358,10 +1365,11 @@ pprModGuts (ModGuts { mg_types = type_env, ppr_rules rules ] -ppr_types :: [Var] -> TypeEnv -> SDoc -ppr_types dfun_ids type_env +ppr_types :: [Instance] -> TypeEnv -> SDoc +ppr_types ispecs type_env = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) where + dfun_ids = map instanceDFunId ispecs ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True | otherwise = isLocalId id && @@ -1372,9 +1380,9 @@ ppr_types dfun_ids type_env -- that the type checker has invented. Top-level user-defined things -- have External names. -ppr_insts :: [Var] -> SDoc -ppr_insts [] = empty -ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids) +ppr_insts :: [Instance] -> SDoc +ppr_insts [] = empty +ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) ppr_sigs :: [Var] -> SDoc ppr_sigs ids @@ -1384,10 +1392,10 @@ ppr_sigs ids le_sig id1 id2 = getOccName id1 <= getOccName id2 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) -ppr_rules :: [IdCoreRule] -> SDoc +ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (pprIdRules rs), + nest 4 (pprRules rs), ptext SLIT("#-}")] ppr_gen_tycons [] = empty diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index bab89d051a..41e1133a60 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -77,6 +77,7 @@ initTc hsc_env hsc_src mod do_this dfuns_var <- newIORef emptyNameSet ; keep_var <- newIORef emptyNameSet ; th_var <- newIORef False ; + dfun_n_var <- newIORef 1 ; let { gbl_env = TcGblEnv { @@ -99,6 +100,7 @@ initTc hsc_env hsc_src mod do_this tcg_insts = [], tcg_rules = [], tcg_fords = [], + tcg_dfun_n = dfun_n_var, tcg_keep = keep_var } ; lcl_env = TcLclEnv { @@ -714,6 +716,13 @@ debugTc thing = return () %************************************************************************ \begin{code} +nextDFunIndex :: TcM Int -- Get the next dfun index +nextDFunIndex = do { env <- getGblEnv + ; let dfun_n_var = tcg_dfun_n env + ; n <- readMutVar dfun_n_var + ; writeMutVar dfun_n_var (n+1) + ; return n } + getLIEVar :: TcM (TcRef LIE) getLIEVar = do { env <- getLclEnv; return (tcl_lie env) } diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index 8edada30ed..3d1329fed7 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -48,7 +48,7 @@ import Packages ( PackageId ) import Type ( Type, TvSubstEnv, pprParendType, pprTyThingCategory ) import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, SkolemInfo, TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes, pprSkolInfo ) -import InstEnv ( DFunId, InstEnv ) +import InstEnv ( Instance, InstEnv ) import IOEnv import RdrName ( GlobalRdrEnv, LocalRdrEnv ) import Name ( Name ) @@ -193,6 +193,17 @@ data TcGblEnv -- tcg_inst_uses; the reference is implicit rather than explicit, -- so we have to zap a mutable variable. + tcg_dfun_n :: TcRef Int, -- Allows us to number off the names of DFuns + -- It's convenient to allocate an External Name for a DFun, with + -- a permanently-fixed unique, just like other top-level functions + -- defined in this module. But that means we need a canonical + -- occurrence name, distinct from all other dfuns in this module, + -- and this name supply serves that purpose (df1, df2, etc). + + -- The next fields accumulate the payload of the module + -- The binds, rules and foreign-decl fiels are collected + -- initially in un-zonked form and are finally zonked in tcRnSrcDecls + -- The next fields accumulate the payload of the -- module The binds, rules and foreign-decl fiels are -- collected initially in un-zonked form and are @@ -203,7 +214,7 @@ data TcGblEnv tcg_binds :: LHsBinds Id, -- Value bindings in this module tcg_deprecs :: Deprecations, -- ...Deprecations - tcg_insts :: [DFunId], -- ...Instances + tcg_insts :: [Instance], -- ...Instances tcg_rules :: [LRuleDecl Id], -- ...Rules tcg_fords :: [LForeignDecl Id] -- ...Foreign import & exports } diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 2e04d90c90..57906add6f 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -37,15 +37,16 @@ import Inst ( lookupInst, LookupInstResult(..), getDictClassTys, isTyVarDict, instLoc, zonkInst, tidyInsts, tidyMoreInsts, Inst, pprInsts, pprDictsInFull, pprInstInFull, tcGetInstEnvs, - isInheritableInst, pprDFuns, pprDictsTheta + isInheritableInst, pprDictsTheta ) import TcEnv ( tcGetGlobalTyVars, tcLookupId, findGlobals, pprBinders ) -import InstEnv ( lookupInstEnv, classInstances ) +import InstEnv ( lookupInstEnv, classInstances, pprInstances ) import TcMType ( zonkTcTyVarsAndFV, tcInstTyVars, checkAmbiguity ) import TcType ( TcTyVar, TcTyVarSet, ThetaType, TcPredType, mkClassPred, isOverloadedTy, mkTyConApp, isSkolemTyVar, mkTyVarTy, tcGetTyVar, isTyVarClassPred, mkTyVarTys, tyVarsOfPred, tcEqType, pprPred, mkPredTy ) +import TcIface ( checkWiredInTyCon ) import Id ( idType, mkUserLocal ) import Var ( TyVar ) import Name ( Name, getOccName, getSrcLoc ) @@ -56,7 +57,7 @@ import PrelInfo ( isNumericClass ) import PrelNames ( splitName, fstName, sndName, integerTyConName, showClassKey, eqClassKey, ordClassKey ) import Type ( zipTopTvSubst, substTheta, substTy ) -import TysWiredIn ( pairTyCon, doubleTy ) +import TysWiredIn ( pairTyCon, doubleTy, doubleTyCon ) import ErrUtils ( Message ) import BasicTypes ( TopLevelFlag, isNotTopLevel ) import VarSet @@ -2180,6 +2181,7 @@ get_default_tys Nothing -> -- No use-supplied default; -- use [Integer, Double] do { integer_ty <- tcMetaTy integerTyConName + ; checkWiredInTyCon doubleTyCon ; return [integer_ty, doubleTy] } } \end{code} @@ -2381,7 +2383,6 @@ addNoInstanceErrs mb_what givens [] addNoInstanceErrs mb_what givens dicts = -- Some of the dicts are here because there is no instances -- and some because there are too many instances (overlap) - getDOpts `thenM` \ dflags -> tcGetInstEnvs `thenM` \ inst_envs -> let (tidy_env1, tidy_givens) = tidyInsts givens @@ -2394,7 +2395,7 @@ addNoInstanceErrs mb_what givens dicts check_overlap (overlap_doc, no_inst_dicts) dict | not (isClassDict dict) = (overlap_doc, dict : no_inst_dicts) | otherwise - = case lookupInstEnv dflags inst_envs clas tys of + = case lookupInstEnv inst_envs clas tys of -- The case of exactly one match and no unifiers means -- a successful lookup. That can't happen here, becuase -- dicts only end up here if they didn't match in Inst.lookupInst @@ -2424,7 +2425,7 @@ addNoInstanceErrs mb_what givens dicts = vcat [ addInstLoc [dict] ((ptext SLIT("Overlapping instances for") <+> pprPred (dictPred dict))), sep [ptext SLIT("Matching instances") <> colon, - nest 2 (vcat [pprDFuns dfuns, pprDFuns unifiers])], + nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])], ASSERT( not (null matches) ) if not (isSingleton matches) then -- Two or more matches @@ -2435,7 +2436,7 @@ addNoInstanceErrs mb_what givens dicts quotes (pprWithCommas ppr (varSetElems (tyVarsOfInst dict))), ptext SLIT("Use -fallow-incoherent-instances to use the first choice above")])] where - dfuns = [df | (_, (_,_,df)) <- matches] + ispecs = [ispec | (_, ispec) <- matches] mk_probable_fix tidy_env dicts = returnM (tidy_env, sep [ptext SLIT("Probable fix:"), nest 2 (vcat fixes)]) diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 08e89b53f1..7f9d82b86a 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -46,7 +46,7 @@ import IfaceEnv ( lookupOrig ) import Class ( Class, classExtraBigSig ) import TyCon ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs, isPrimTyCon, isFunTyCon, - tyConArity, isUnLiftedTyCon ) + tyConArity, tyConStupidTheta, isUnLiftedTyCon ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, isVanillaDataCon ) @@ -569,12 +569,13 @@ reifyTyCon tc reifyTyCon tc = case algTyConRhs tc of NewTyCon data_con _ _ - -> do { con <- reifyDataCon data_con - ; return (TH.TyConI $ TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc)) + -> do { cxt <- reifyCxt (tyConStupidTheta tc) + ; con <- reifyDataCon data_con + ; return (TH.TyConI $ TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) con [{- Don't know about deriving -}]) } - DataTyCon mb_cxt cons _ - -> do { cxt <- reifyCxt (mb_cxt `orElse` []) + DataTyCon cons _ + -> do { cxt <- reifyCxt (tyConStupidTheta tc) ; cons <- mapM reifyDataCon (tyConDataCons tc) ; return (TH.TyConI $ TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) cons [{- Don't know about deriving -}]) } diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 7186fa93bc..9b664af692 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -12,8 +12,8 @@ module TcTyClsDecls ( import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), , NewOrData(..), - tyClDeclTyVars, isSynDecl, LConDecl, - LTyClDecl, tcdName, LHsTyVarBndr, LHsContext + tyClDeclTyVars, isSynDecl, + LTyClDecl, tcdName, LHsTyVarBndr ) import HsTypes ( HsBang(..), getBangStrictness ) import BasicTypes ( RecFlag(..), StrictnessMark(..) ) @@ -33,7 +33,7 @@ import TcHsType ( kcHsTyVars, kcHsLiftedSigType, kcHsType, import TcMType ( newKindVar, checkValidTheta, checkValidType, checkFreeness, UserTypeCtxt(..), SourceTyCtxt(..) ) import TcUnify ( unifyKind ) -import TcType ( TcKind, ThetaType, TcType, tyVarsOfType, +import TcType ( TcKind, TcType, tyVarsOfType, mkArrowKind, liftedTypeKind, mkTyVarTys, tcEqTypes, tcSplitSigmaTy, tcEqType ) import Type ( splitTyConApp_maybe, pprThetaArrow, pprParendType ) @@ -374,8 +374,7 @@ tcTyClDecl1 calc_vrcs calc_isrec = tcTyVarBndrs tvs $ \ tvs' -> do { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs - ; stupid_theta <- tcStupidTheta ctxt cons - + ; stupid_theta <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics ; unbox_strict <- doptM Opt_UnboxStrictFields ; gla_exts <- doptM Opt_GlasgowExts @@ -398,10 +397,10 @@ tcTyClDecl1 calc_vrcs calc_isrec = AbstractTyCon -- "don't know"; hence Abstract | otherwise = case new_or_data of - DataType -> mkDataTyConRhs stupid_theta data_cons + DataType -> mkDataTyConRhs data_cons NewType -> ASSERT( isSingleton data_cons ) mkNewTyConRhs tycon (head data_cons) - ; buildAlgTyCon tc_name final_tvs tc_rhs arg_vrcs is_rec + ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs arg_vrcs is_rec (want_generic && canDoGenerics data_cons) }) ; return (ATyCon tycon) @@ -518,15 +517,6 @@ tcConDecl unbox_strict DataType tycon tc_tvs -- GADTs -- can complain if it's wrong. ------------------- -tcStupidTheta :: LHsContext Name -> [LConDecl Name] -> TcM (Maybe ThetaType) --- For GADTs we don't allow a context on the data declaration --- whereas for standard Haskell style data declarations, we do -tcStupidTheta ctxt (L _ (ConDecl _ _ _ _) : _) - = do { theta <- tcHsKindedContext ctxt; return (Just theta) } -tcStupidTheta ctxt other -- Includes an empty constructor list - = ASSERT( null (unLoc ctxt) ) return Nothing - -------------------- argStrictness :: Bool -- True <=> -funbox-strict_fields -> TyCon -> [HsBang] -> [TcType] -> [StrictnessMark] diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index bdef13107f..9ca2703e0d 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -753,18 +753,9 @@ hoistForAllTys ty \begin{code} deNoteType :: Type -> Type - -- Remove synonyms, but not predicate types -deNoteType ty@(TyVarTy tyvar) = ty -deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) -deNoteType (PredTy p) = PredTy (deNotePredType p) -deNoteType (NoteTy _ ty) = deNoteType ty -deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) -deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) -deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) - -deNotePredType :: PredType -> PredType -deNotePredType (ClassP c tys) = ClassP c (map deNoteType tys) -deNotePredType (IParam n ty) = IParam n (deNoteType ty) +-- Remove *outermost* type synonyms and other notes +deNoteType (NoteTy _ ty) = deNoteType ty +deNoteType ty = ty \end{code} Find the free tycons and classes of a type. This is used in the front @@ -776,8 +767,8 @@ tyClsNamesOfType (TyVarTy tv) = emptyNameSet tyClsNamesOfType (TyConApp tycon tys) = unitNameSet (getName tycon) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (NoteTy (SynNote ty1) ty2) = tyClsNamesOfType ty1 tyClsNamesOfType (NoteTy other_note ty2) = tyClsNamesOfType ty2 -tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty -tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys +tyClsNamesOfType (PredTy (IParam n ty)) = tyClsNamesOfType ty +tyClsNamesOfType (PredTy (ClassP cl tys)) = unitNameSet (getName cl) `unionNameSets` tyClsNamesOfTypes tys tyClsNamesOfType (FunTy arg res) = tyClsNamesOfType arg `unionNameSets` tyClsNamesOfType res tyClsNamesOfType (AppTy fun arg) = tyClsNamesOfType fun `unionNameSets` tyClsNamesOfType arg tyClsNamesOfType (ForAllTy tyvar ty) = tyClsNamesOfType ty diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index ec5c9a4775..60648b733a 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -26,7 +26,6 @@ module TcUnify ( #include "HsVersions.h" --- gaw 2004 import HsSyn ( HsExpr(..) , MatchGroup(..), hsLMatchPats ) import TcHsSyn ( mkHsLet, mkHsDictLam, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) @@ -52,14 +51,15 @@ import TcMType ( condLookupTcTyVar, LookupTyVarResult(..), newTyFlexiVarTy, zonkTcKind, zonkType, zonkTcType, zonkTcTyVarsAndFV, readKindVar, writeKindVar ) import TcSimplify ( tcSimplifyCheck ) +import TcIface ( checkWiredInTyCon ) import TcEnv ( tcGetGlobalTyVars, findGlobals ) -import TyCon ( TyCon, tyConArity, tyConTyVars ) +import TyCon ( TyCon, tyConArity, tyConTyVars, tyConName ) import TysWiredIn ( listTyCon ) import Id ( Id, mkSysLocal ) import Var ( Var, varName, tyVarKind ) import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems ) import VarEnv -import Name ( isSystemName, mkSysTvName ) +import Name ( isSystemName, mkSysTvName, isWiredInName ) import ErrUtils ( Message ) import SrcLoc ( noLoc ) import BasicTypes ( Arity ) @@ -233,12 +233,15 @@ zapToTyConApp :: TyCon -- T :: k1 -> ... -> kn -> * -> Expected TcSigmaType -- Expected type (T a b c) -> TcM [TcType] -- Element types, a b c -- Insists that the Expected type is not a forall-type - + -- It's used for wired-in tycons, so we call checkWiredInTyCOn zapToTyConApp tc (Check ty) - = unifyTyConApp tc ty -- NB: fails for a forall-type + = do { checkWiredInTyCon tc ; unifyTyConApp tc ty } -- NB: fails for a forall-type + zapToTyConApp tc (Infer hole) = do { (tc_app, elt_tys) <- newTyConApp tc ; writeMutVar hole tc_app + ; traceTc (text "zap" <+> ppr tc) + ; checkWiredInTyCon tc ; return elt_tys } zapToListTy :: Expected TcType -> TcM TcType -- Special case for lists diff --git a/ghc/compiler/types/FunDeps.lhs b/ghc/compiler/types/FunDeps.lhs index f1d58da9bf..af42ee98a6 100644 --- a/ghc/compiler/types/FunDeps.lhs +++ b/ghc/compiler/types/FunDeps.lhs @@ -8,21 +8,26 @@ It's better to read it as: "if we know these, then we're going to know these" \begin{code} module FunDeps ( Equation, pprEquation, pprEquationDoc, - oclose, grow, improve, checkInstFDs, checkClsFD, pprFundeps + oclose, grow, improve, + checkInstFDs, checkFunDeps, + pprFundeps ) where #include "HsVersions.h" -import Name ( getSrcLoc ) -import Var ( Id, TyVar ) +import Name ( Name, getSrcLoc ) +import Var ( TyVar ) import Class ( Class, FunDep, classTvsFds ) import Unify ( tcUnifyTys, BindFlag(..) ) import Type ( substTys, notElemTvSubst ) -import TcType ( Type, ThetaType, PredType(..), tcEqType, +import TcType ( Type, ThetaType, PredType(..), tcEqType, predTyUnique, mkClassPred, tyVarsOfTypes, tyVarsOfPred ) +import InstEnv ( Instance(..), InstEnv, instanceHead, classInstances, + instanceCantMatch, roughMatchTcs ) import VarSet import VarEnv import Outputable +import Util ( notNull ) import List ( tails ) import Maybe ( isJust ) import ListSetOps ( equivClassesByUniq ) @@ -174,18 +179,11 @@ pprEquation (qtvs, pairs) nest 2 (vcat [ ppr t1 <+> ptext SLIT(":=:") <+> ppr t2 | (t1,t2) <- pairs])] ---------- -improve :: InstEnv Id -- Gives instances for given class +improve :: (Class -> [Instance]) -- Gives instances for given class -> [(PredType,SDoc)] -- Current constraints; doc says where they come from -> [(Equation,SDoc)] -- Derived equalities that must also hold -- (NB the above INVARIANT for type Equation) -- The SDoc explains why the equation holds (for error messages) - -type InstEnv a = Class -> [(TyVarSet, [Type], a)] --- This is a bit clumsy, because InstEnv is really --- defined in module InstEnv. However, we don't want --- to define it here because InstEnv --- is their home. Nor do we want to make a recursive --- module group (InstEnv imports stuff from FunDeps). \end{code} Given a bunch of predicates that must hold, such as @@ -223,7 +221,9 @@ improve inst_env preds eqn <- checkGroup inst_env group ] ---------- -checkGroup :: InstEnv Id -> [(PredType,SDoc)] -> [(Equation, SDoc)] +checkGroup :: (Class -> [Instance]) + -> [(PredType,SDoc)] + -> [(Equation, SDoc)] -- The preds are all for the same class or implicit param checkGroup inst_env (p1@(IParam _ ty, _) : ips) @@ -249,7 +249,7 @@ checkGroup inst_env clss@((ClassP cls _, _) : _) where (cls_tvs, cls_fds) = classTvsFds cls - cls_inst_env = inst_env cls + instances = inst_env cls -- NOTE that we iterate over the fds first; they are typically -- empty, which aborts the rest of the loop. @@ -265,12 +265,17 @@ checkGroup inst_env clss@((ClassP cls _, _) : _) instance_eqns :: [(Equation,SDoc)] instance_eqns -- This group comes from comparing with instance decls = [ (eqn, mkEqnMsg p1 p2) - | fd <- cls_fds, - (qtvs, tys1, dfun_id) <- cls_inst_env, - let p1 = (mkClassPred cls tys1, - ptext SLIT("arising from the instance declaration at") <+> ppr (getSrcLoc dfun_id)), + | fd <- cls_fds, -- Iterate through the fundeps first, + -- because there often are none! p2@(ClassP _ tys2, _) <- clss, - eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2 + let rough_tcs2 = trimRoughMatchTcs cls_tvs fd (roughMatchTcs tys2), + ispec@(Instance { is_tvs = qtvs, is_tys = tys1, + is_tcs = mb_tcs1 }) <- instances, + not (instanceCantMatch mb_tcs1 rough_tcs2), + eqn <- checkClsFD qtvs fd cls_tvs tys1 tys2, + let p1 = (mkClassPred cls tys1, + ptext SLIT("arising from the instance declaration at") <+> + ppr (getSrcLoc ispec)) ] mkEqnMsg (pred1,from1) (pred2,from2) @@ -373,6 +378,87 @@ checkInstFDs theta clas inst_taus (ls,rs) = instFD fd tyvars inst_taus \end{code} + +%************************************************************************ +%* * + Check that a new instance decl is OK wrt fundeps +%* * +%************************************************************************ + +Here is the bad case: + class C a b | a->b where ... + instance C Int Bool where ... + instance C Int Char where ... + +The point is that a->b, so Int in the first parameter must uniquely +determine the second. In general, given the same class decl, and given + + instance C s1 s2 where ... + instance C t1 t2 where ... + +Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). + +Matters are a little more complicated if there are free variables in +the s2/t2. + + class D a b c | a -> b + instance D a b => D [(a,a)] [b] Int + instance D a b => D [a] [b] Bool + +The instance decls don't overlap, because the third parameter keeps +them separate. But we want to make sure that given any constraint + D s1 s2 s3 +if s1 matches + + +\begin{code} +checkFunDeps :: (InstEnv, InstEnv) -> Instance + -> Maybe [Instance] -- Nothing <=> ok + -- Just dfs <=> conflict with dfs +-- Check wheher adding DFunId would break functional-dependency constraints +-- Used only for instance decls defined in the module being compiled +checkFunDeps inst_envs ispec + | null bad_fundeps = Nothing + | otherwise = Just bad_fundeps + where + (ins_tvs, _, clas, ins_tys) = instanceHead ispec + ins_tv_set = mkVarSet ins_tvs + cls_inst_env = classInstances inst_envs clas + bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys + +badFunDeps :: [Instance] -> Class + -> TyVarSet -> [Type] -- Proposed new instance type + -> [Instance] +badFunDeps cls_insts clas ins_tv_set ins_tys + = [ ispec | fd <- fds, -- fds is often empty + let trimmed_tcs = trimRoughMatchTcs clas_tvs fd rough_tcs, + ispec@(Instance { is_tcs = mb_tcs, is_tvs = tvs, + is_tys = tys }) <- cls_insts, + -- Filter out ones that can't possibly match, + -- based on the head of the fundep + not (instanceCantMatch trimmed_tcs mb_tcs), + notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) + fd clas_tvs tys ins_tys) + ] + where + (clas_tvs, fds) = classTvsFds clas + rough_tcs = roughMatchTcs ins_tys + +trimRoughMatchTcs :: [TyVar] -> FunDep TyVar -> [Maybe Name] -> [Maybe Name] +-- Computing rough_tcs for a particular fundep +-- class C a b c | a c -> b where ... +-- For each instance .... => C ta tb tc +-- we want to match only on the types ta, tb; so our +-- rough-match thing must similarly be filtered. +-- Hence, we Nothing-ise the tb type right here +trimRoughMatchTcs clas_tvs (ltvs,_) mb_tcs + = zipWith select clas_tvs mb_tcs + where + select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc + | otherwise = Nothing +\end{code} + + %************************************************************************ %* * \subsection{Miscellaneous} @@ -386,3 +472,4 @@ pprFundeps fds = hsep (ptext SLIT("|") : punctuate comma (map ppr_fd fds)) ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs] \end{code} + diff --git a/ghc/compiler/types/InstEnv.lhs b/ghc/compiler/types/InstEnv.lhs index 1be556b221..cd0661100d 100644 --- a/ghc/compiler/types/InstEnv.lhs +++ b/ghc/compiler/types/InstEnv.lhs @@ -7,31 +7,37 @@ The bits common to TcInstDcls and TcDeriv. \begin{code} module InstEnv ( - DFunId, InstEnv, - - emptyInstEnv, extendInstEnv, extendInstEnvList, - lookupInstEnv, instEnvElts, - classInstances, simpleDFunClassTyCon, checkFunDeps + DFunId, OverlapFlag(..), + Instance(..), pprInstance, pprInstances, + instanceHead, mkLocalInstance, mkImportedInstance, + instanceDFunId, setInstanceDFunId, instanceRoughTcs, + + InstEnv, emptyInstEnv, extendInstEnv, + extendInstEnvList, lookupInstEnv, instEnvElts, + classInstances, + instanceCantMatch, roughMatchTcs ) where #include "HsVersions.h" -import Class ( Class, classTvsFds ) -import Var ( Id, isTcTyVar ) +import Class ( Class ) +import Var ( Id, TyVar, isTcTyVar ) import VarSet +import Name ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom, nameModule ) +import OccName ( OccName ) +import NameSet ( unionNameSets, unitNameSet, nameSetToList ) import Type ( TvSubst ) -import TcType ( Type, tcTyConAppTyCon, tcIsTyVarTy, - tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar +import TcType ( Type, PredType, tcEqType, + tcSplitDFunTy, tyVarsOfTypes, isExistentialTyVar, + pprThetaArrow, pprClassPred, + tyClsNamesOfType, tcSplitTyConApp_maybe ) +import TyCon ( tyConName ) import Unify ( tcMatchTys, tcUnifyTys, BindFlag(..) ) -import FunDeps ( checkClsFD ) -import TyCon ( TyCon ) import Outputable import UniqFM ( UniqFM, lookupUFM, emptyUFM, addToUFM_C, eltsUFM ) -import Id ( idType ) -import DynFlags -import Util ( notNull ) -import Maybe ( isJust ) +import Id ( idType, idName ) +import Maybe ( isJust, isNothing ) \end{code} @@ -41,102 +47,203 @@ import Maybe ( isJust ) %* * %************************************************************************ -A @ClsInstEnv@ all the instances of that class. The @Id@ inside a -ClsInstEnv mapping is the dfun for that instance. - -If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then - - forall a b, C t1 t2 t3 can be constructed by dfun - -or, to put it another way, we have - - instance (...) => C t1 t2 t3, witnessed by dfun - \begin{code} -type DFunId = Id -type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class - -data ClsInstEnv - = ClsIE [InstEnvElt] -- The instances for a particular class, in any order - Bool -- True <=> there is an instance of form C a b c - -- If *not* then the common case of looking up - -- (C a b c) can fail immediately - -- NB: use tcIsTyVarTy: don't look through newtypes!! - -type InstEnvElt = (TyVarSet, [Type], DFunId) - --- INVARIANTS: --- * [a,b] must be a superset of the free vars of [t1,t2,t3] +type DFunId = Id +data Instance + = Instance { is_cls :: Name -- Class name + + -- Used for "rough matching"; see note below + , is_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; see note + , is_tvs :: TyVarSet -- Template tyvars for full match + , is_tys :: [Type] -- Full arg types + + , is_dfun :: DFunId + , is_flag :: OverlapFlag + + , is_orph :: Maybe OccName } + +-- The "rough-match" fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The is_cls, is_args fields allow a "rough match" to be done +-- without poking inside the DFunId. Poking the DFunId forces +-- us to suck in all the type constructors etc it involves, +-- which is a total waste of time if it has no chance of matching +-- So the Name, [Maybe Name] fields allow us to say "definitely +-- does not match", based only on the Name. -- --- * The dfun must itself be quantified over [a,b] +-- In is_tcs, +-- Nothing means that this type arg is a type variable -- --- * The template type variables [a,b] are distinct in each item --- of a ClsInstEnv (so we can safely unify them) - --- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: --- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] --- The "a" in the pattern must be one of the forall'd variables in --- the dfun type. - - -emptyInstEnv :: InstEnv -emptyInstEnv = emptyUFM - -instEnvElts :: InstEnv -> [InstEnvElt] -instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts] +-- (Just n) means that this type arg is a +-- TyConApp with a type constructor of n. +-- This is always a real tycon, never a synonym! +-- (Two different synonyms might match, but two +-- different real tycons can't.) +-- NB: newtypes are not transparent, though! +-- +-- The "proper-match" fields +-- ~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The is_tvs, is_tys fields are simply cahced values, pulled +-- out (lazily) from the dfun id. They are cached here simply so +-- that we don't need to decompose the DFunId each time we want +-- to match it. The hope is that the fast-match fields mean +-- that we often never poke th proper-match fields +-- +-- However, note that: +-- * is_tvs must be a superset of the free vars of is_tys +-- +-- * The is_dfun must itself be quantified over exactly is_tvs +-- (This is so that we can use the matching substitution to +-- instantiate the dfun's context.) +-- +-- The "orphan" field +-- ~~~~~~~~~~~~~~~~~~ +-- An instance is an orphan if its head (after the =>) mentions +-- nothing defined in this module. +-- +-- Just n The head mentions n, which is defined in this module +-- This is used for versioning; the instance decl is +-- considered part of the defn of n when computing versions +-- +-- Nothing The head mentions nothing defined in this modle +-- +-- If a module contains any orphans, then its interface file is read +-- regardless, so that its instances are not missed. +-- +-- Functional dependencies worsen the situation a bit. Consider +-- class C a b | a -> b +-- In some other module we might have +-- module M where +-- data T = ... +-- instance C Int T where ... +-- This isn't considered an orphan, so we will only read M's interface +-- if something from M is used (e.g. T). So there's a risk we'll +-- miss the improvement from the instance. Workaround: import M. + +instanceDFunId :: Instance -> DFunId +instanceDFunId = is_dfun + +setInstanceDFunId :: Instance -> DFunId -> Instance +setInstanceDFunId ispec dfun + = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) ) + -- We need to create the cached fields afresh from + -- the new dfun id. In particular, the is_tvs in + -- the Instance must match those in the dfun! + -- We assume that the only thing that changes is + -- the quantified type variables, so the other fields + -- are ok; hence the assert + ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } + where + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) + +instanceRoughTcs :: Instance -> [Maybe Name] +instanceRoughTcs = is_tcs +\end{code} -classInstances :: (InstEnv,InstEnv) -> Class -> [InstEnvElt] -classInstances (pkg_ie, home_ie) cls - = get home_ie ++ get pkg_ie +\begin{code} +instance NamedThing Instance where + getName ispec = getName (is_dfun ispec) + +instance Outputable Instance where + ppr = pprInstance + +pprInstance :: Instance -> SDoc +-- Prints the Instance as an instance declaration +pprInstance ispec@(Instance { is_flag = flag }) + = hang (ptext SLIT("instance") <+> ppr flag + <+> sep [pprThetaArrow theta, pprClassPred clas tys]) + 2 (ppr (getSrcLoc ispec)) where - get env = case lookupUFM env cls of - Just (ClsIE insts _) -> insts - Nothing -> [] - -extendInstEnvList :: InstEnv -> [DFunId] -> InstEnv -extendInstEnvList inst_env dfuns = foldl extendInstEnv inst_env dfuns - -extendInstEnv :: InstEnv -> DFunId -> InstEnv -extendInstEnv inst_env dfun_id - = addToUFM_C add inst_env clas (ClsIE [ins_item] ins_tyvar) + (_, theta, clas, tys) = instanceHead ispec + -- Print without the for-all, which the programmer doesn't write + +pprInstances :: [Instance] -> SDoc +pprInstances ispecs = vcat (map pprInstance ispecs) + +instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type]) +instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec)) + +mkLocalInstance :: DFunId -> OverlapFlag -> Instance +-- Used for local instances, where we can safely pull on the DFunId +mkLocalInstance dfun oflag + = Instance { is_flag = oflag, is_dfun = dfun, + is_tvs = mkVarSet tvs, is_tys = tys, + is_cls = cls_name, is_tcs = roughMatchTcs tys, + is_orph = orph } where - add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) - (ins_tyvar || cur_tyvar) - (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun_id) - ins_tv_set = mkVarSet ins_tvs - ins_item = (ins_tv_set, ins_tys, dfun_id) - ins_tyvar = all tcIsTyVarTy ins_tys - -#ifdef UNUSED -pprInstEnv :: InstEnv -> SDoc -pprInstEnv env - = vcat [ brackets (pprWithCommas ppr (varSetElems tyvars)) <+> - brackets (pprWithCommas ppr tys) <+> ppr dfun - | ClsIE cls_inst_env _ <- eltsUFM env - , (tyvars, tys, dfun) <- cls_inst_env - ] -#endif - -simpleDFunClassTyCon :: DFunId -> (Class, TyCon) -simpleDFunClassTyCon dfun - = (clas, tycon) + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) + mod = nameModule (idName dfun) + cls_name = getName cls + tycl_names = foldr (unionNameSets . tyClsNamesOfType) + (unitNameSet cls_name) tys + orph = case filter (nameIsLocalOrFrom mod) (nameSetToList tycl_names) of + [] -> Nothing + (n:ns) -> Just (getOccName n) + +mkImportedInstance :: Name -> [Maybe Name] -> Maybe OccName + -> DFunId -> OverlapFlag -> Instance +-- Used for imported instances, where we get the rough-match stuff +-- from the interface file +mkImportedInstance cls mb_tcs orph dfun oflag + = Instance { is_flag = oflag, is_dfun = dfun, + is_tvs = mkVarSet tvs, is_tys = tys, + is_cls = cls, is_tcs = mb_tcs, is_orph = orph } where - (_,_,clas,[ty]) = tcSplitDFunTy (idType dfun) - tycon = tcTyConAppTyCon ty -\end{code} + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) -%************************************************************************ -%* * -\subsection{Instance environments: InstEnv and ClsInstEnv} -%* * -%************************************************************************ +roughMatchTcs :: [Type] -> [Maybe Name] +roughMatchTcs tys = map rough tys + where + rough ty = case tcSplitTyConApp_maybe ty of + Just (tc,_) -> Just (tyConName tc) + Nothing -> Nothing + +instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool +-- (instanceCantMatch tcs1 tcs2) returns True if tcs1 cannot +-- possibly be instantiated to actual, nor vice versa; +-- False is non-committal +instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as +instanceCantMatch ts as = False -- Safe + +--------------------------------------------------- +data OverlapFlag + = NoOverlap -- This instance must not overlap another + + | OverlapOk -- Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instances (Foo [Int]) + -- (Foo [a]) OverlapOk + -- Since the second instance has the OverlapOk flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + | Incoherent -- Like OverlapOk, but also ignore this instance + -- if it doesn't match the constraint you are + -- trying to resolve, but could match if the type variables + -- in the constraint were instantiated + -- + -- Example: constraint (Foo [b]) + -- instances (Foo [Int]) Incoherent + -- (Foo [a]) + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen + +instance Outputable OverlapFlag where + ppr NoOverlap = empty + ppr OverlapOk = ptext SLIT("[overlap ok]") + ppr Incoherent = ptext SLIT("[incoherent]") +\end{code} -Notes on overlapping instances +Note [Overlapping instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In some ClsInstEnvs, overlap is prohibited; that is, no pair of templates unify. - -In others, overlap is permitted, but only in such a way that one can make +Overlap is permitted, but only in such a way that one can make a unique choice when looking up. That is, overlap is only permitted if one template matches the other, or vice versa. So this is ok: @@ -259,6 +366,69 @@ Simple story: unify, don't match. %************************************************************************ %* * + InstEnv, ClsInstEnv +%* * +%************************************************************************ + +A @ClsInstEnv@ all the instances of that class. The @Id@ inside a +ClsInstEnv mapping is the dfun for that instance. + +If class C maps to a list containing the item ([a,b], [t1,t2,t3], dfun), then + + forall a b, C t1 t2 t3 can be constructed by dfun + +or, to put it another way, we have + + instance (...) => C t1 t2 t3, witnessed by dfun + +\begin{code} +--------------------------------------------------- +type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class + +data ClsInstEnv + = ClsIE [Instance] -- The instances for a particular class, in any order + Bool -- True <=> there is an instance of form C a b c + -- If *not* then the common case of looking up + -- (C a b c) can fail immediately + +-- INVARIANTS: +-- * The is_tvs are distinct in each Instance +-- of a ClsInstEnv (so we can safely unify them) + +-- Thus, the @ClassInstEnv@ for @Eq@ might contain the following entry: +-- [a] ===> dfun_Eq_List :: forall a. Eq a => Eq [a] +-- The "a" in the pattern must be one of the forall'd variables in +-- the dfun type. + +emptyInstEnv :: InstEnv +emptyInstEnv = emptyUFM + +instEnvElts :: InstEnv -> [Instance] +instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts] + +classInstances :: (InstEnv,InstEnv) -> Class -> [Instance] +classInstances (pkg_ie, home_ie) cls + = get home_ie ++ get pkg_ie + where + get env = case lookupUFM env cls of + Just (ClsIE insts _) -> insts + Nothing -> [] + +extendInstEnvList :: InstEnv -> [Instance] -> InstEnv +extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs + +extendInstEnv :: InstEnv -> Instance -> InstEnv +extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs }) + = addToUFM_C add inst_env cls_nm (ClsIE [ins_item] ins_tyvar) + where + add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) + (ins_tyvar || cur_tyvar) + ins_tyvar = not (any isJust mb_tcs) +\end{code} + + +%************************************************************************ +%* * \subsection{Looking up an instance} %* * %************************************************************************ @@ -268,12 +438,11 @@ the env is kept ordered, the first match must be the only one. The thing we are looking up can have an arbitrary "flexi" part. \begin{code} -lookupInstEnv :: DynFlags - -> (InstEnv -- External package inst-env +lookupInstEnv :: (InstEnv -- External package inst-env ,InstEnv) -- Home-package inst-env -> Class -> [Type] -- What we are looking for - -> ([(TvSubst, InstEnvElt)], -- Successful matches - [Id]) -- These don't match but do unify + -> ([(TvSubst, Instance)], -- Successful matches + [Instance]) -- These don't match but do unify -- The second component of the tuple happens when we look up -- Foo [a] -- in an InstEnv that has entries for @@ -284,56 +453,63 @@ lookupInstEnv :: DynFlags -- but Foo [Int] is a unifier. This gives the caller a better chance of -- giving a suitable error messagen -lookupInstEnv dflags (pkg_ie, home_ie) cls tys - | not (null all_unifs) = (all_matches, all_unifs) -- This is always an error situation, - -- so don't attempt to pune the matches - | otherwise = (pruned_matches, []) +lookupInstEnv (pkg_ie, home_ie) cls tys + = (pruned_matches, all_unifs) where - all_tvs = all tcIsTyVarTy tys - incoherent_ok = dopt Opt_AllowIncoherentInstances dflags - overlap_ok = dopt Opt_AllowOverlappingInstances dflags - (home_matches, home_unifs) = lookup_inst_env home_ie cls tys all_tvs - (pkg_matches, pkg_unifs) = lookup_inst_env pkg_ie cls tys all_tvs + rough_tcs = roughMatchTcs tys + all_tvs = all isNothing rough_tcs + (home_matches, home_unifs) = lookup home_ie + (pkg_matches, pkg_unifs) = lookup pkg_ie all_matches = home_matches ++ pkg_matches - all_unifs | incoherent_ok = [] -- Don't worry about these if incoherent is ok! - | otherwise = home_unifs ++ pkg_unifs - - pruned_matches | overlap_ok = foldr insert_overlapping [] all_matches - | otherwise = all_matches - -lookup_inst_env :: InstEnv -- The envt - -> Class -> [Type] -- What we are looking for - -> Bool -- All the [Type] are tyvars - -> ([(TvSubst, InstEnvElt)], -- Successful matches - [Id]) -- These don't match but do unify -lookup_inst_env env key_cls key_tys key_all_tvs - = case lookupUFM env key_cls of - Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts has_tv_insts) - | key_all_tvs && not has_tv_insts -> ([],[]) -- Short cut for common case - -- The thing we are looking up is of form (C a b c), and - -- the ClsIE has no instances of that form, so don't bother to search - | otherwise -> find insts [] [] - where - find [] ms us = (ms, us) - find (item@(tpl_tyvars, tpl, dfun_id) : rest) ms us - = case tcMatchTys tpl_tyvars tpl key_tys of - Just subst -> find rest ((subst,item):ms) us - Nothing - -- Does not match, so next check whether the things unify - -- [see notes about overlapping instances above] - -> ASSERT2( not (tyVarsOfTypes key_tys `intersectsVarSet` tpl_tyvars), - (ppr key_cls <+> ppr key_tys <+> ppr key_all_tvs) $$ - (ppr dfun_id <+> ppr tpl_tyvars <+> ppr tpl) - ) + all_unifs = home_unifs ++ pkg_unifs + pruned_matches + | null all_unifs = foldr insert_overlapping [] all_matches + | otherwise = all_matches -- Non-empty unifs is always an error situation, + -- so don't attempt to pune the matches + + -------------- + lookup env = case lookupUFM env cls of + Nothing -> ([],[]) -- No instances for this class + Just (ClsIE insts has_tv_insts) + | all_tvs && not has_tv_insts + -> ([],[]) -- Short cut for common case + -- The thing we are looking up is of form (C a b c), and + -- the ClsIE has no instances of that form, so don't bother to search + + | otherwise + -> find [] [] insts + + -------------- + find ms us [] = (ms, us) + find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, + is_tys = tpl_tys, is_flag = oflag, + is_dfun = dfun }) : rest) + -- Fast check for no match, uses the "rough match" fields + | instanceCantMatch rough_tcs mb_tcs + = find ms us rest + + | Just subst <- tcMatchTys tpl_tvs tpl_tys tys + = find ((subst,item):ms) us rest + + -- Does not match, so next check whether the things unify + -- See Note [overlapping instances] above + | Incoherent <- oflag + = find ms us rest + + | otherwise + = ASSERT2( not (tyVarsOfTypes tys `intersectsVarSet` tpl_tvs), + (ppr cls <+> ppr tys <+> ppr all_tvs) $$ + (ppr dfun <+> ppr tpl_tvs <+> ppr tpl_tys) + ) -- Unification will break badly if the variables overlap -- They shouldn't because we allocate separate uniques for them - case tcUnifyTys bind_fn tpl key_tys of - Just _ -> find rest ms (dfun_id:us) - Nothing -> find rest ms us + case tcUnifyTys bind_fn tpl_tys tys of + Just _ -> find ms (item:us) rest + Nothing -> find ms us rest - bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem - | otherwise = BindMe +--------------- +bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem + | otherwise = BindMe -- The key_tys can contain skolem constants, and we can guarantee that those -- are never going to be instantiated to anything, so we should not involve -- them in the unification test. Example: @@ -352,8 +528,9 @@ lookup_inst_env env key_cls key_tys key_all_tvs -- g x = op x -- on the grounds that the correct instance depends on the instantiation of 'a' -insert_overlapping :: (TvSubst, InstEnvElt) -> [(TvSubst, InstEnvElt)] - -> [(TvSubst, InstEnvElt)] +--------------- +insert_overlapping :: (TvSubst, Instance) -> [(TvSubst, Instance)] + -> [(TvSubst, Instance)] -- Add a new solution, knocking out strictly less specific ones insert_overlapping new_item [] = [new_item] insert_overlapping new_item (item:items) @@ -369,66 +546,14 @@ insert_overlapping new_item (item:items) new_beats_old = new_item `beats` item old_beats_new = item `beats` new_item - (_, (tvs1, tys1, _)) `beats` (_, (tvs2, tys2, _)) - = isJust (tcMatchTys tvs2 tys2 tys1) -- A beats B if A is more specific than B - -- I.e. if B can be instantiated to match A + (_, instA) `beats` (_, instB) + = overlap_ok && + isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA)) + -- A beats B if A is more specific than B, and B admits overlap + -- I.e. if B can be instantiated to match A + where + overlap_ok = case is_flag instB of + NoOverlap -> False + other -> True \end{code} - -%************************************************************************ -%* * - Functional dependencies -%* * -%************************************************************************ - -Here is the bad case: - class C a b | a->b where ... - instance C Int Bool where ... - instance C Int Char where ... - -The point is that a->b, so Int in the first parameter must uniquely -determine the second. In general, given the same class decl, and given - - instance C s1 s2 where ... - instance C t1 t2 where ... - -Then the criterion is: if U=unify(s1,t1) then U(s2) = U(t2). - -Matters are a little more complicated if there are free variables in -the s2/t2. - - class D a b c | a -> b - instance D a b => D [(a,a)] [b] Int - instance D a b => D [a] [b] Bool - -The instance decls don't overlap, because the third parameter keeps -them separate. But we want to make sure that given any constraint - D s1 s2 s3 -if s1 matches - - -\begin{code} -checkFunDeps :: (InstEnv, InstEnv) -> DFunId - -> Maybe [DFunId] -- Nothing <=> ok - -- Just dfs <=> conflict with dfs --- Check wheher adding DFunId would break functional-dependency constraints -checkFunDeps inst_envs dfun - | null bad_fundeps = Nothing - | otherwise = Just bad_fundeps - where - (ins_tvs, _, clas, ins_tys) = tcSplitDFunTy (idType dfun) - ins_tv_set = mkVarSet ins_tvs - cls_inst_env = classInstances inst_envs clas - bad_fundeps = badFunDeps cls_inst_env clas ins_tv_set ins_tys - -badFunDeps :: [InstEnvElt] -> Class - -> TyVarSet -> [Type] -- Proposed new instance type - -> [DFunId] -badFunDeps cls_inst_env clas ins_tv_set ins_tys - = [ dfun_id | fd <- fds, - (tvs, tys, dfun_id) <- cls_inst_env, - notNull (checkClsFD (tvs `unionVarSet` ins_tv_set) fd clas_tvs tys ins_tys) - ] - where - (clas_tvs, fds) = classTvsFds clas -\end{code} diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 29f4600309..944d0ab1b0 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -12,12 +12,14 @@ module TyCon( AlgTyConRhs(..), visibleDataCons, - isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAbstractTyCon, + isFunTyCon, isUnLiftedTyCon, isProductTyCon, isAlgTyCon, isDataTyCon, isSynTyCon, isNewTyCon, isPrimTyCon, isEnumerationTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, newTyConRhs, newTyConRhs_maybe, isHiBootTyCon, + makeTyConAbstract, isAbstractTyCon, + mkForeignTyCon, isForeignTyCon, mkAlgTyCon, @@ -103,13 +105,16 @@ data TyCon -- * its type (scoped over tby tyConTyVars) -- * record selector (name = field name) + algTcStupidTheta :: [PredType], -- The "stupid theta" for the data type + -- (always empty for GADTs) + algTcRhs :: AlgTyConRhs, -- Data constructors in here algTcRec :: RecFlag, -- Tells whether the data type is part of -- a mutually-recursive group or not hasGenerics :: Bool, -- True <=> generic to/from functions are available - -- (in the exports of the data type's source module) + -- (in the exports of the data type's source module) algTcClass :: Maybe Class -- Just cl if this tycon came from a class declaration @@ -168,13 +173,6 @@ data AlgTyConRhs -- an hi file | DataTyCon - (Maybe [PredType]) -- Just theta => this tycon was declared in H98 syntax - -- with the specified "stupid theta" - -- e.g. data Ord a => T a = ... - -- Nothing => this tycon was declared by giving the - -- type signatures for each constructor - -- (new GADT stuff) - -- e.g. data T a where { ... } [DataCon] -- The constructors; can be empty if the user declares -- the type to have no constructors -- INVARIANT: Kept in order of increasing tag @@ -202,9 +200,9 @@ data AlgTyConRhs -- newtypes. visibleDataCons :: AlgTyConRhs -> [DataCon] -visibleDataCons AbstractTyCon = [] -visibleDataCons (DataTyCon _ cs _) = cs -visibleDataCons (NewTyCon c _ _) = [c] +visibleDataCons AbstractTyCon = [] +visibleDataCons (DataTyCon cs _) = cs +visibleDataCons (NewTyCon c _ _) = [c] \end{code} %************************************************************************ @@ -269,7 +267,7 @@ mkFunTyCon name kind -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyCon name kind tyvars argvrcs rhs flds is_rec gen_info +mkAlgTyCon name kind tyvars argvrcs stupid rhs flds is_rec gen_info = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -277,6 +275,7 @@ mkAlgTyCon name kind tyvars argvrcs rhs flds is_rec gen_info tyConArity = length tyvars, tyConTyVars = tyvars, argVrcs = argvrcs, + algTcStupidTheta = stupid, algTcRhs = rhs, algTcFields = flds, algTcClass = Nothing, @@ -292,6 +291,7 @@ mkClassTyCon name kind tyvars argvrcs rhs clas is_rec tyConArity = length tyvars, tyConTyVars = tyvars, argVrcs = argvrcs, + algTcStupidTheta = [], algTcRhs = rhs, algTcFields = [], algTcClass = Just clas, @@ -370,6 +370,10 @@ isAbstractTyCon :: TyCon -> Bool isAbstractTyCon (AlgTyCon { algTcRhs = AbstractTyCon }) = True isAbstractTyCon _ = False +makeTyConAbstract :: TyCon -> TyCon +makeTyConAbstract tc@(AlgTyCon {}) = tc { algTcRhs = AbstractTyCon } +makeTyConAbstract tc = pprPanic "makeTyConAbstract" (ppr tc) + isPrimTyCon :: TyCon -> Bool isPrimTyCon (PrimTyCon {}) = True isPrimTyCon _ = False @@ -395,9 +399,9 @@ isDataTyCon :: TyCon -> Bool -- unboxed tuples isDataTyCon (AlgTyCon {algTcRhs = rhs}) = case rhs of - DataTyCon _ _ _ -> True - NewTyCon _ _ _ -> False - AbstractTyCon -> panic "isDataTyCon" + DataTyCon _ _ -> True + NewTyCon _ _ _ -> False + AbstractTyCon -> panic "isDataTyCon" isDataTyCon (TupleTyCon {tyConBoxed = boxity}) = isBoxed boxity isDataTyCon other = False @@ -415,9 +419,9 @@ isProductTyCon :: TyCon -> Bool -- may be unboxed or not, -- may be recursive or not isProductTyCon tc@(AlgTyCon {}) = case algTcRhs tc of - DataTyCon _ [data_con] _ -> isVanillaDataCon data_con - NewTyCon _ _ _ -> True - other -> False + DataTyCon [data_con] _ -> isVanillaDataCon data_con + NewTyCon _ _ _ -> True + other -> False isProductTyCon (TupleTyCon {}) = True isProductTyCon other = False @@ -426,8 +430,8 @@ isSynTyCon (SynTyCon {}) = True isSynTyCon _ = False isEnumerationTyCon :: TyCon -> Bool -isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon _ _ is_enum}) = is_enum -isEnumerationTyCon other = False +isEnumerationTyCon (AlgTyCon {algTcRhs = DataTyCon _ is_enum}) = is_enum +isEnumerationTyCon other = False isTupleTyCon :: TyCon -> Bool -- The unit tycon didn't used to be classed as a tuple tycon @@ -473,15 +477,15 @@ tyConDataCons :: TyCon -> [DataCon] tyConDataCons tycon = tyConDataCons_maybe tycon `orElse` [] tyConDataCons_maybe :: TyCon -> Maybe [DataCon] -tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon _ cons _}) = Just cons -tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon con _ _}) = Just [con] -tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] -tyConDataCons_maybe other = Nothing +tyConDataCons_maybe (AlgTyCon {algTcRhs = DataTyCon cons _}) = Just cons +tyConDataCons_maybe (AlgTyCon {algTcRhs = NewTyCon con _ _}) = Just [con] +tyConDataCons_maybe (TupleTyCon {dataCon = con}) = Just [con] +tyConDataCons_maybe other = Nothing tyConFamilySize :: TyCon -> Int -tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon _ cons _}) = length cons -tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = 1 -tyConFamilySize (TupleTyCon {}) = 1 +tyConFamilySize (AlgTyCon {algTcRhs = DataTyCon cons _}) = length cons +tyConFamilySize (AlgTyCon {algTcRhs = NewTyCon _ _ _}) = 1 +tyConFamilySize (TupleTyCon {}) = 1 #ifdef DEBUG tyConFamilySize other = pprPanic "tyConFamilySize:" (ppr other) #endif @@ -495,13 +499,14 @@ tyConSelIds tc = [id | (_,_,id) <- tyConFields tc] algTyConRhs :: TyCon -> AlgTyConRhs algTyConRhs (AlgTyCon {algTcRhs = rhs}) = rhs -algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon (Just []) [con] False +algTyConRhs (TupleTyCon {dataCon = con}) = DataTyCon [con] False algTyConRhs other = pprPanic "algTyConRhs" (ppr other) \end{code} \begin{code} newTyConRhs :: TyCon -> ([TyVar], Type) newTyConRhs (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ rhs _}) = (tvs, rhs) +newTyConRhs tycon = pprPanic "newTyConRhs" (ppr tycon) newTyConRhs_maybe :: TyCon -> [Type] -- Args to tycon @@ -521,6 +526,7 @@ newTyConRhs_maybe other_tycon tys = Nothing newTyConRep :: TyCon -> ([TyVar], Type) newTyConRep (AlgTyCon {tyConTyVars = tvs, algTcRhs = NewTyCon _ _ rep}) = (tvs, rep) +newTyConRep tycon = pprPanic "newTyConRep" (ppr tycon) tyConPrimRep :: TyCon -> PrimRep tyConPrimRep (PrimTyCon {primTyConRep = rep}) = rep @@ -529,10 +535,9 @@ tyConPrimRep tc = ASSERT(not (isUnboxedTupleTyCon tc)) PtrRep \begin{code} tyConStupidTheta :: TyCon -> [PredType] -tyConStupidTheta (AlgTyCon {algTcRhs = DataTyCon mb_th _ _}) = mb_th `orElse` [] -tyConStupidTheta (AlgTyCon {algTcRhs = other}) = [] -tyConStupidTheta (TupleTyCon {}) = [] --- shouldn't ask about anything else +tyConStupidTheta (AlgTyCon {algTcStupidTheta = stupid}) = stupid +tyConStupidTheta (TupleTyCon {}) = [] +tyConStupidTheta tycon = pprPanic "tyConStupidTheta" (ppr tycon) \end{code} @tyConArgVrcs_maybe@ gives a list of (occPos,occNeg) flags, one for @@ -551,16 +556,17 @@ tyConArgVrcs (SynTyCon {argVrcs = oi}) = oi \begin{code} getSynTyConDefn :: TyCon -> ([TyVar], Type) getSynTyConDefn (SynTyCon {tyConTyVars = tyvars, synTyConDefn = ty}) = (tyvars,ty) +getSynTyConDefn tycon = pprPanic "getSynTyConDefn" (ppr tycon) \end{code} \begin{code} maybeTyConSingleCon :: TyCon -> Maybe DataCon -maybeTyConSingleCon (AlgTyCon {algTcRhs = DataTyCon _ [c] _}) = Just c -maybeTyConSingleCon (AlgTyCon {algTcRhs = NewTyCon c _ _}) = Just c -maybeTyConSingleCon (AlgTyCon {}) = Nothing -maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con -maybeTyConSingleCon (PrimTyCon {}) = Nothing -maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty +maybeTyConSingleCon (AlgTyCon {algTcRhs = DataTyCon [c] _}) = Just c +maybeTyConSingleCon (AlgTyCon {algTcRhs = NewTyCon c _ _}) = Just c +maybeTyConSingleCon (AlgTyCon {}) = Nothing +maybeTyConSingleCon (TupleTyCon {dataCon = con}) = Just con +maybeTyConSingleCon (PrimTyCon {}) = Nothing +maybeTyConSingleCon (FunTyCon {}) = Nothing -- case at funty maybeTyConSingleCon tc = pprPanic "maybeTyConSingleCon: unexpected tycon " $ ppr tc \end{code} |