summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ghc/compiler/NOTES2
-rw-r--r--ghc/compiler/basicTypes/Id.lhs10
-rw-r--r--ghc/compiler/basicTypes/IdInfo.lhs37
-rw-r--r--ghc/compiler/basicTypes/MkId.lhs17
-rw-r--r--ghc/compiler/basicTypes/Name.lhs9
-rw-r--r--ghc/compiler/basicTypes/OccName.lhs18
-rw-r--r--ghc/compiler/codeGen/CodeGen.lhs2
-rw-r--r--ghc/compiler/coreSyn/CoreFVs.lhs101
-rw-r--r--ghc/compiler/coreSyn/CoreSubst.lhs38
-rw-r--r--ghc/compiler/coreSyn/CoreSyn.lhs100
-rw-r--r--ghc/compiler/coreSyn/CoreTidy.lhs46
-rw-r--r--ghc/compiler/coreSyn/PprCore.lhs28
-rw-r--r--ghc/compiler/deSugar/Desugar.lhs96
-rw-r--r--ghc/compiler/ghci/InteractiveUI.hs11
-rw-r--r--ghc/compiler/iface/BinIface.hs74
-rw-r--r--ghc/compiler/iface/BuildTyCl.lhs13
-rw-r--r--ghc/compiler/iface/IfaceEnv.lhs2
-rw-r--r--ghc/compiler/iface/IfaceSyn.lhs219
-rw-r--r--ghc/compiler/iface/IfaceType.lhs8
-rw-r--r--ghc/compiler/iface/LoadIface.lhs205
-rw-r--r--ghc/compiler/iface/MkIface.lhs185
-rw-r--r--ghc/compiler/iface/TcIface.hi-boot-63
-rw-r--r--ghc/compiler/iface/TcIface.lhs328
-rw-r--r--ghc/compiler/main/DriverPipeline.hs35
-rw-r--r--ghc/compiler/main/GHC.hs3
-rw-r--r--ghc/compiler/main/HscMain.lhs73
-rw-r--r--ghc/compiler/main/HscTypes.lhs92
-rw-r--r--ghc/compiler/main/TidyPgm.lhs465
-rw-r--r--ghc/compiler/prelude/PrelRules.lhs30
-rw-r--r--ghc/compiler/prelude/TysWiredIn.lhs7
-rw-r--r--ghc/compiler/rename/RnEnv.lhs4
-rw-r--r--ghc/compiler/rename/RnExpr.lhs4
-rw-r--r--ghc/compiler/rename/RnNames.lhs3
-rw-r--r--ghc/compiler/simplCore/OccurAnal.lhs16
-rw-r--r--ghc/compiler/simplCore/SetLevels.lhs4
-rw-r--r--ghc/compiler/simplCore/SimplCore.lhs155
-rw-r--r--ghc/compiler/simplCore/SimplEnv.lhs10
-rw-r--r--ghc/compiler/specialise/Rules.lhs356
-rw-r--r--ghc/compiler/specialise/SpecConstr.lhs14
-rw-r--r--ghc/compiler/specialise/Specialise.lhs12
-rw-r--r--ghc/compiler/typecheck/Inst.lhs119
-rw-r--r--ghc/compiler/typecheck/TcClassDcl.lhs11
-rw-r--r--ghc/compiler/typecheck/TcDeriv.lhs110
-rw-r--r--ghc/compiler/typecheck/TcEnv.lhs46
-rw-r--r--ghc/compiler/typecheck/TcExpr.lhs2
-rw-r--r--ghc/compiler/typecheck/TcHsSyn.lhs2
-rw-r--r--ghc/compiler/typecheck/TcHsType.lhs18
-rw-r--r--ghc/compiler/typecheck/TcInstDcls.lhs28
-rw-r--r--ghc/compiler/typecheck/TcRnDriver.lhs96
-rw-r--r--ghc/compiler/typecheck/TcRnMonad.lhs9
-rw-r--r--ghc/compiler/typecheck/TcRnTypes.lhs15
-rw-r--r--ghc/compiler/typecheck/TcSimplify.lhs15
-rw-r--r--ghc/compiler/typecheck/TcSplice.lhs11
-rw-r--r--ghc/compiler/typecheck/TcTyClsDecls.lhs22
-rw-r--r--ghc/compiler/typecheck/TcType.lhs19
-rw-r--r--ghc/compiler/typecheck/TcUnify.lhs13
-rw-r--r--ghc/compiler/types/FunDeps.lhs125
-rw-r--r--ghc/compiler/types/InstEnv.lhs549
-rw-r--r--ghc/compiler/types/TyCon.lhs84
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}