+
+-------------------------
*** unexpected failure for jtod_circint(opt)
#include "HsVersions.h"
-import CoreSyn ( Unfolding, CoreRules, IdCoreRule(..), rulesRules )
+import CoreSyn ( Unfolding, CoreRule )
import BasicTypes ( Arity )
import Var ( Id, DictId,
isId, isExportedId, isSpecPragmaId, isLocalId,
---------------------------------
-- 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
---------------------------------
occInfo, setOccInfo,
-- Specialisation
- specInfo, setSpecInfo,
+ SpecInfo(..), specInfo, setSpecInfo, isEmptySpecInfo,
+ specInfoFreeVars, specInfoRules, seqSpecInfo,
-- CAF info
CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
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,
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
megaSeqIdInfo :: IdInfo -> ()
megaSeqIdInfo info
- = seqRules (specInfo info) `seq`
+ = seqSpecInfo (specInfo info) `seq`
seqWorker (workerInfo info) `seq`
-- Omitting this improves runtimes a little, presumably because
demandInfo = wwLazy,
strictnessInfo = NoStrictnessInfo,
#endif
- specInfo = emptyCoreRules,
+ specInfo = emptySpecInfo,
workerInfo = NoWorker,
unfoldingInfo = noUnfolding,
lbvarInfo = NoLBVarInfo,
%************************************************************************
%* *
+ 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@}
%* *
%************************************************************************
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,
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
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,
setNameOcc,
hashName, localiseName,
- nameSrcLoc, nameParent, nameParent_maybe,
+ nameSrcLoc, nameParent, nameParent_maybe, isImplicitName,
isSystemName, isInternalName, isExternalName,
isTyVarName, isWiredInName, isBuiltInSyntax,
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}
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
import Util ( thenCmp )
import Unique ( Unique, mkUnique, Uniquable(..) )
import BasicTypes ( Boxity(..), Arity )
+import StaticFlags ( opt_PprStyle_Debug )
import UniqFM
import UniqSet
import FastString
\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
#ifdef DEBUG
import Outputable
#endif
-
-import DATA_IOREF ( readIORef )
\end{code}
\begin{code}
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
#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 )
\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
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)
= 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}
%* *
%************************************************************************
-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
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}
%************************************************************************
\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}
-- | otherwise = emptyVarSet
idRuleVars ::Id -> VarSet
-idRuleVars id = ASSERT( isId id) rulesRhsFreeVars (idSpecialisation id)
+idRuleVars id = ASSERT( isId id) specInfoFreeVars (idSpecialisation id)
\end{code}
-- Substitution stuff
Subst, TvSubstEnv, IdSubstEnv, InScopeSet,
- substTy, substExpr, substRules, substWorker,
+ substTy, substExpr, substSpec, substWorker,
lookupIdSubst, lookupTvSubst,
emptySubst, mkEmptySubst, mkSubst, substInScope, isEmptySubst,
#include "HsVersions.h"
import CoreSyn ( Expr(..), Bind(..), Note(..), CoreExpr,
- CoreRules(..), CoreRule(..),
- isEmptyCoreRules, seqRules, hasUnfolding, noUnfolding
+ CoreRule(..), hasUnfolding, noUnfolding
)
import CoreFVs ( exprFreeVars )
import CoreUtils ( exprIsTrivial )
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 )
-- 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))
-- 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
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"
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 )
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
%* *
%************************************************************************
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}
\begin{code}
module CoreTidy (
- tidyExpr, tidyVarOcc,
- tidyIdRules, pprTidyIdRules
+ tidyExpr, tidyVarOcc, tidyRule, tidyRules
) where
#include "HsVersions.h"
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 )
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}
%************************************************************************
\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
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
- pprIdRules
+ pprRules
) where
#include "HsVersions.h"
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
- newStrictnessInfo, cafInfo, ppCafInfo,
+ newStrictnessInfo, cafInfo, ppCafInfo, specInfoRules
)
#ifdef OLD_STRICTNESS
#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
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}
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 )
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 )
| 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
ppr_ds_rules [] = empty
ppr_ds_rules rules
= text "" $$ text "-------------- DESUGARED RULES -----------------" $$
- pprIdRules rules
+ pprRules rules
\end{code}
%************************************************************************
\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}
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
= 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
import NewDemand
import IfaceSyn
import VarEnv
+import InstEnv ( OverlapFlag(..) )
import Packages ( PackageIdH(..) )
import Class ( DefMeth(..) )
import CostCentre
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
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
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
put_ bh a4
put_ bh a5
put_ bh a6
+ put_ bh a7
put_ bh (IfaceSyn aq ar as at) = do
putByte bh 3
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
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)
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
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)
------------------------------------------------------
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
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
; rhs = case dict_component_tys of
[rep_ty] -> mkNewTyConRhs tycon dict_con
- other -> mkDataTyConRhs Nothing [dict_con]
+ other -> mkDataTyConRhs [dict_con]
}
; return clas
})}
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
visibleIfConDecls,
-- Converting things to IfaceSyn
- tyThingToIfaceDecl, dfunToIfaceInst, coreRuleToIfaceRule,
+ tyThingToIfaceDecl, instanceToIfaceInst, coreRuleToIfaceRule,
-- Equality
IfaceEq(..), (&&&), bool, eqListBy, eqMaybeBy,
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(..),
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,
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 )
| 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,
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 {
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,
= 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
| 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
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})
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 {
-- 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}
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
------------------
\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,
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,
| 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,
| 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),
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]
--------------------------
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
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
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
-- Conversion from Type -> IfaceType
toIfaceType, toIfacePred, toIfaceContext,
- toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs,
+ toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon,
-- Printing
pprIfaceType, pprParendIfaceType, pprIfaceContext,
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
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
)
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 )
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
%* *
%************************************************************************
elaborate err = hang (ptext SLIT("Failed to load interface for") <+>
quotes (ppr mod) <> colon) 4 err
+---------------
loadOrphanModules :: [Module] -> TcM ()
loadOrphanModules mods
| null mods = returnM ()
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
\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)
; 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)
}}}}
= 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
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}
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}
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
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,
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,
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,
\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,
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,
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))
; 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
-- 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
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,
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)
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
= (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
module TcIface where
tcIfaceDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL TypeRep.TyThing
+tcIfaceInst :: IfaceSyn.IfaceInst -> TcRnTypes.IfL InstEnv.Instance
+tcIfaceRule :: IfaceSyn.IfaceRule -> TcRnTypes.IfL CoreSyn.CoreRule
+
\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(..),
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 )
\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
tcIfaceDecl (IfaceData {ifName = occ_name,
ifTyVars = tv_bndrs,
+ ifCtxt = ctxt,
ifCons = rdr_cons,
ifVrcs = arg_vrcs, ifRec = is_rec,
ifGeneric = want_generic })
; 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)
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
%* *
%************************************************************************
-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
(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}
-- 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
\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 ;
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
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
-- 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,
#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)
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
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 )
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
#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 )
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
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(..) )
import ParserCoreUtils
import FastString
import Maybes ( expectJust )
-import StringBuffer ( StringBuffer )
import Bag ( unitBag, emptyBag )
-
import Monad ( when )
import Maybe ( isJust )
import IO
------------------------------
--- hscNoRecomp definitely expects to have the old interface available
hscNoRecomp hsc_env msg_act mod_summary
have_object (Just old_iface)
mb_mod_index
; 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 {
-------------------
; (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
}}}}}
------------------------------
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)
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,
; 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 ())
-------------------
-- 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
-- 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
\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
; 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
WhetherHasOrphans, IsBootInterface, Usage(..),
Dependencies(..), noDependencies,
- InstPool, Gated, addInstsToPool,
- RulePool, addRulesToPool,
NameCache(..), OrigNameCache, OrigIParamCache,
Avails, availsToNameSet, availName, availNames,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
Deprecations, DeprecTxt, lookupDeprec, plusDeprecs,
- InstEnv, DFunId,
PackageInstEnv, PackageRuleBase,
-- Linker stuff
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 )
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 )
\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
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,
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
}
-- 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
-- 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
}
, 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
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,
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}
%************************************************************************
\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 )
\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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
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
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,
-- 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}
%************************************************************************
%************************************************************************
\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
| 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
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
-- "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
\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}
--
-- * 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
-- 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.
, 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 )
\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
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 (>=))
%************************************************************************
\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
]
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,
(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
--
-- 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
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) $ \ _ ->
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` []
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
\begin{code}
module OccurAnal (
- occurAnalysePgm, occurAnalyseGlobalExpr, occurAnalyseRule,
+ occurAnalysePgm, occurAnalyseGlobalExpr
) where
#include "HsVersions.h"
isExportedId, idArity, idSpecialisation,
idType, idUnique, Id
)
+import IdInfo ( isEmptySpecInfo )
import BasicTypes ( OccInfo(..), isOneOcc )
import VarSet
= -- 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}
| 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
-- 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.
isOneShotLambda, zapDemandIdInfo,
idSpecialisation, idWorkerInfo, setIdInfo
)
-import IdInfo ( workerExists, vanillaIdInfo, )
+import IdInfo ( workerExists, vanillaIdInfo, isEmptySpecInfo )
import Var ( Var )
import VarSet
import VarEnv
-- 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
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 )
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)
(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"
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
-- 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}
-> 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
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
-- 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}
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:
-> 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)
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
#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
(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
-- 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
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
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)]
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
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}
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
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,
| 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
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))
\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}
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}
+
%************************************************************************
%* *
%************************************************************************
\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
-- 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}
%************************************************************************
%* *
-\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}
%* *
%************************************************************************
| 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
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"
, 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}
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(..) )
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
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))
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
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
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)
module Inst (
Inst,
- pprDFuns, pprDictsTheta, pprDictsInFull, -- User error messages
+ pprInstances, pprDictsTheta, pprDictsInFull, -- User error messages
showLIE, pprInst, pprInsts, pprInstInFull, -- Debugging messages
tidyInsts, tidyMoreInsts,
instLoc, getDictClassTys, dictPred,
lookupInst, LookupInstResult(..), lookupPred,
- tcExtendLocalInstEnv, tcGetInstEnvs,
+ tcExtendLocalInstEnv, tcGetInstEnvs, getOverlapFlag,
isDict, isClassDict, isMethod,
isLinearInst, linearInstType, isIPDict, isInheritableInst,
)
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,
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 )
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}
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
%************************************************************************
\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
-- (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}
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) ])
= 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)
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,
-- 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}
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)
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 )
)
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(..) )
= 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
= 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))
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
= -- 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
| 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
\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
-- 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
(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
\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
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
TyThing(..), TcTyThing(..), TcId,
-- Instance environment, and InstInfo type
- InstInfo(..), pprInstInfo, pprInstInfoDetails,
- simpleInstInfoTy, simpleInstInfoTyCon,
+ InstInfo(..), iDFunId, pprInstInfo, pprInstInfoDetails,
+ simpleInstInfoClsTy, simpleInstInfoTy, simpleInstInfoTyCon,
InstBindings(..),
-- Global environment
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
)
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(..) )
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
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}
\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
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,
-> 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
; (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 ->
getBangStrictness, collectSigTysFromHsBinds )
import RnHsSyn ( extractHsTyVars )
import TcRnMonad
-import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
+import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv,
tcLookup, tcLookupClass, tcLookupTyCon,
TyThing(..), getInLocalScope, wrongThingErr
)
checkValidType, UserTypeCtxt(..), pprHsSigCtxt
)
import TcUnify ( unifyFunKind, checkExpectedKind )
+import TcIface ( checkWiredInTyCon )
import TcType ( Type, PredType(..), ThetaType,
MetaDetails(Flexi), hoistForAllTys,
TcType, TcTyVar, TcKind, TcThetaType, TcTauType,
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 )
= 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 ->
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(..),
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
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}
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}
\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
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 )
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 )
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 )
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 )
availNames, availName, ModIface(..), icPrintUnqual,
ModDetails(..), Dependencies(..) )
import BasicTypes ( RecFlag(..), Fixity )
-import Bag ( unitBag )
import ListSetOps ( removeDups )
import Panic ( ghcError, GhcException(..) )
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}
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)
= 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
|| 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)
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}
---------------------
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?
-- 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
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
; 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 []
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 &&
-- 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
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
dfuns_var <- newIORef emptyNameSet ;
keep_var <- newIORef emptyNameSet ;
th_var <- newIORef False ;
+ dfun_n_var <- newIORef 1 ;
let {
gbl_env = TcGblEnv {
tcg_insts = [],
tcg_rules = [],
tcg_fords = [],
+ tcg_dfun_n = dfun_n_var,
tcg_keep = keep_var
} ;
lcl_env = TcLclEnv {
%************************************************************************
\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) }
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 )
-- 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
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
}
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 )
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
Nothing -> -- No use-supplied default;
-- use [Integer, Double]
do { integer_ty <- tcMetaTy integerTyConName
+ ; checkWiredInTyCon doubleTyCon
; return [integer_ty, doubleTy] } }
\end{code}
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
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
= 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
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)])
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 )
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 -}]) }
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(..) )
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 )
= 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
= 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)
-- 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]
\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
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
#include "HsVersions.h"
--- gaw 2004
import HsSyn ( HsExpr(..) , MatchGroup(..), hsLMatchPats )
import TcHsSyn ( mkHsLet, mkHsDictLam,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
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 )
-> 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
\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 )
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
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)
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.
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)
(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}
ppr_fd (us, vs) = hsep [interppSP us, ptext SLIT("->"), interppSP vs]
\end{code}
+
\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}
%* *
%************************************************************************
-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:
%************************************************************************
%* *
+ 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}
%* *
%************************************************************************
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
-- 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:
-- 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)
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}
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,
-- * 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
-- 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
-- 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}
%************************************************************************
-- 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,
tyConArity = length tyvars,
tyConTyVars = tyvars,
argVrcs = argvrcs,
+ algTcStupidTheta = stupid,
algTcRhs = rhs,
algTcFields = flds,
algTcClass = Nothing,
tyConArity = length tyvars,
tyConTyVars = tyvars,
argVrcs = argvrcs,
+ algTcStupidTheta = [],
algTcRhs = rhs,
algTcFields = [],
algTcClass = Just clas,
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
-- 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
-- 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
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
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
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
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
\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
\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}
projects / ghc-hetmet.git / commitdiff