\begin{code}
module TcIface (
tcImportDecl, typecheckIface,
- tcIfaceKind, loadImportedInsts,
+ tcIfaceKind, loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
#include "HsVersions.h"
import TcRnMonad
import Type ( Kind, openTypeKind, liftedTypeKind,
unliftedTypeKind, mkArrowKind, splitTyConApp,
- mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+ mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
-import HscTypes ( ExternalPackageState(..), PackageInstEnv,
- TyThing(..), implicitTyThings,
- ModIface(..), ModDetails(..), InstPool,
+import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
+ HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
+ ModIface(..), ModDetails(..), InstPool, ModGuts,
TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
- DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
+ RulePool, Pool(..) )
import InstEnv ( extendInstEnv )
import CoreSyn
+import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
import CoreUtils ( exprType )
import CoreUnfold
import UniqSupply ( initUs_ )
import Outputable
import SrcLoc ( noSrcLoc )
-import Util ( zipWithEqual, dropList, equalLength )
+import Util ( zipWithEqual, dropList, equalLength, zipLazy )
import Maybes ( expectJust )
import CmdLineOpts ( DynFlag(..) )
\end{code}
= do {
-- Make sure the interface is loaded
; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name }
- ; traceIf nd_doc
+ ; traceIf (nd_doc <+> char '{') -- Brace matches the later message
; loadHomeInterface nd_doc name
-- Get the real name of the thing, with a correct nameParent field.
- -- Before the interface is loaded, we may have a non-commital 'Nothing' in
- -- the namePareent field (made up by IfaceEnv.lookupOrig), but
+ -- Before the interface is loaded, we may have a non-committal 'Nothing'
+ -- in the namePareent field (made up by IfaceEnv.lookupOrig), but
-- loading the interface updates the name cache.
-- We need the right nameParent field in getThing
; real_name <- lookupOrig (nameModuleName name) (nameOccName name)
; let { extra | getName main_thing == real_name = empty
| otherwise = brackets (ptext SLIT("when seeking") <+> ppr real_name) }
- ; traceIf (ptext SLIT("...imported decl for") <+> ppr main_thing <+> extra)
+ ; traceIf (ptext SLIT(" ...imported decl for") <+> ppr main_thing <+> extra <+> char '}')
-- Look up the wanted Name in the type envt; it might be
-- whose gates are all in the type envt, is in eps_rule_base
recordImportOf thing
- = do { (new_things, iface_rules) <- updateEps (\ eps ->
+ = do { new_things <- updateEps (\ eps ->
let { new_things = thing : implicitTyThings thing
; new_type_env = extendTypeEnvList (eps_PTE eps) new_things
-- NB: opportunity for a very subtle loop here!
-- * which pokes the suspended forks
-- * which, to execute, need to consult type-env (to check
-- entirely unrelated types, perhaps)
-
- ; (new_rules, iface_rules) = selectRules (eps_rules eps)
- (map getName new_things)
- new_type_env }
- in (eps { eps_PTE = new_type_env, eps_rules = new_rules },
- (new_things, iface_rules))
+ }
+ in (eps { eps_PTE = new_type_env }, new_things)
)
-
- -- Now type-check those rules (which may side-effect the EPS again)
; traceIf (text "tcImport: extend type env" <+> ppr new_things)
- ; core_rules <- mapM tc_rule iface_rules
- ; updateEps_ (\ eps ->
- eps { eps_rule_base = extendRuleBaseList (eps_rule_base eps) core_rules }
- ) }
+ }
-tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
-
getThing :: Name -> IfG TyThing
-- Find and typecheck the thing; the Name might be a "subordinate name"
-- of the "main thing" (e.g. the constructor of a data type declaration)
| otherwise = do -- The normal case, not wired in
{ -- Get the decl from the pool
- decl <- updateEps (\ eps ->
- let
- (decls', decl) = selectDecl (eps_decls eps) name
- in
- (eps { eps_decls = decls' }, decl))
-
- -- Typecheck it
- -- Side-effects EPS by faulting in any needed decls
- -- (via nested calls to tcImportDecl)
- ; initIfaceLcl (nameModuleName name) (tcIfaceDecl decl) }
-
+ mb_decl <- updateEps (\ eps -> selectDecl eps name)
+
+ ; case mb_decl of
+ Just decl -> initIfaceLcl (nameModuleName name) (tcIfaceDecl decl)
+ -- Typecheck it
+ -- Side-effects EPS by faulting in any needed decls
+ -- (via nested calls to tcImportDecl)
+
+
+ Nothing -> do { ioToIOEnv (printErrs (msg defaultErrStyle)); failM }
+ -- Declaration not found
+ -- No errors-var to accumulate errors in, so just
+ -- print out the error right now
+
+ }
+ where
+ msg = hang (ptext SLIT("Can't find interface-file declaration for") <+> ppr (nameParent name))
+ 2 (vcat [ptext SLIT("Probable cause: bug in .hi-boot file, or inconsistent .hi file"),
+ ptext SLIT("Use -ddump-if-trace to get an idea of which file caused the error")])
-selectDecl :: DeclPool -> Name -> (DeclPool, IfaceDecl)
+selectDecl :: ExternalPackageState -> Name -> (ExternalPackageState, Maybe IfaceDecl)
-- Use nameParent to get the parent name of the thing
-selectDecl (Pool decls_map n_in n_out) name
- = (Pool decls' n_in (n_out+1), decl)
+selectDecl eps@(EPS { eps_decls = Pool decls_map n_in n_out}) name
+ = case lookupNameEnv decls_map main_name of
+ Nothing -> (eps, Nothing)
+ Just decl -> (eps {eps_decls = Pool decls' n_in (n_out+1)}, Just decl)
where
main_name = nameParent name
- decl = case lookupNameEnv decls_map main_name of
- Nothing -> pprPanic "selectDecl" (ppr main_name <+> ppr name) ;
- Just decl -> decl
-
- decls' = delFromNameEnv decls_map main_name
+ decls' = delFromNameEnv decls_map main_name
\end{code}
%************************************************************************
%* *
- Other interfaces
+ Type-checking a complete interface
%* *
%************************************************************************
+Suppose we discover we don't need to recompile. Then we must type
+check the old interface file. This is a bit different to the
+incremental type checking we do as we suck in interface files. Instead
+we do things similarly as when we are typechecking source decls: we
+bring into scope the type envt for the interface all at once, using a
+knot. Remember, the decls aren't necessarily in dependency order --
+and even if they were, the type decls might be mutually recursive.
+
\begin{code}
-typecheckIface :: ModIface -> IfG ModDetails
--- Used when we decide not to recompile, but intead to use the
--- interface to construct the type environment for the module
-typecheckIface iface
- = initIfaceLcl (moduleName (mi_module iface)) $
- do { ty_things <- mapM (tcIfaceDecl . snd) (mi_decls iface)
- ; rules <- mapM tcIfaceRule (mi_rules iface)
+typecheckIface :: HscEnv
+ -> ModIface -- Get the decls from here
+ -> IO ModDetails
+typecheckIface hsc_env iface@(ModIface { mi_module = mod, mi_decls = ver_decls,
+ mi_rules = rules, mi_insts = dfuns })
+ = initIfaceTc hsc_env iface $ \ tc_env_var -> do
+ { -- Typecheck the decls
+ names <- mappM (lookupOrig (moduleName mod) . ifName) decls
+ ; ty_things <- fixM (\ rec_ty_things -> do
+ { writeMutVar tc_env_var (mkNameEnv (names `zipLazy` rec_ty_things))
+ -- This only makes available the "main" things,
+ -- but that's enough for the strictly-checked part
+ ; mapM tcIfaceDecl decls })
+
+ -- Now augment the type envt with all the implicit things
+ -- These will be needed when type-checking the unfoldings for
+ -- the IfaceIds, but this is done lazily, so writing the thing
+ -- now is sufficient
+ ; let { add_implicits main_thing = main_thing : implicitTyThings main_thing
+ ; type_env = mkTypeEnv (concatMap add_implicits ty_things) }
+ ; writeMutVar tc_env_var type_env
+
+ -- Now do those rules and instances
; dfuns <- mapM tcIfaceInst (mi_insts iface)
- ; return (ModDetails { md_types = mkTypeEnv ty_things,
- md_insts = dfuns,
- md_rules = rules }) }
+ ; rules <- mapM tcIfaceRule (mi_rules iface)
+
+ -- Finished
+ ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
+ }
+ where
+ decls = map snd ver_decls
\end{code}
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
-- Suck in the instances
; let { (inst_pool', iface_insts)
- = selectInsts (eps_insts eps) cls_gate tc_gates }
-
- ; traceTc (text "loadImportedInsts" <+> vcat [ppr cls <+> ppr tys,
- text "new pool" <+> ppr inst_pool',
- text "new insts" <+> ppr iface_insts])
+ = WARN( null tc_gates, ptext SLIT("Interesting! No tycons in Inst:")
+ <+> pprClassPred cls tys )
+ selectInsts (eps_insts eps) cls_gate tc_gates }
-- Empty => finish up rapidly, without writing to eps
; if null iface_insts then
else do
{ writeMutVar eps_var (eps {eps_insts = inst_pool'})
+ ; traceIf (sep [ptext SLIT("Importing instances for") <+> pprClassPred cls tys,
+ nest 2 (vcat (map ppr iface_insts))])
+
-- Typecheck the new instances
; dfuns <- initIfaceTcRn (mappM tc_inst iface_insts)
(insts', iface_insts)
= case lookupNameEnv insts cls of {
Nothing -> (insts, []) ;
- Just gated_insts ->
+ Just gated_insts ->
- case foldl choose ([],[]) gated_insts of {
+ 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
- choose (gis, decls) (gates, decl)
- | any (`elem` tycons) gates = (gis, decl:decls)
- | otherwise = ((gates,decl) : gis, decls)
+ 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)
\end{code}
%************************************************************************
(as a side effect) augment the type envt, and so we may need to iterate the process.
\begin{code}
-selectRules :: RulePool
- -> [Name] -- Names of things being added
- -> TypeEnv -- New type env, including things being added
- -> (RulePool, [(ModuleName, IfaceRule)])
-selectRules (Pool rules n_in n_out) new_names type_env
- = (Pool rules' n_in (n_out + length iface_rules), iface_rules)
+loadImportedRules :: HscEnv -> ModGuts -> IO PackageRuleBase
+loadImportedRules hsc_env guts
+ = initIfaceRules hsc_env guts $ do
+ { -- Get new rules
+ if_rules <- updateEps (\ eps ->
+ let { (new_pool, if_rules) = selectRules (eps_rules eps) (eps_PTE eps) }
+ in (eps { eps_rules = new_pool }, if_rules) )
+
+ ; traceIf (ptext SLIT("Importing rules:") <+> vcat (map ppr if_rules))
+
+ ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
+ ; 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.
+ }
+
+
+selectRules :: RulePool -> TypeEnv -> (RulePool, [(ModuleName, 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 (Pool rules n_in n_out) type_env
+ = (Pool rules' n_in (n_out + length if_rules), if_rules)
where
- (rules', iface_rules) = foldl select_one (rules, []) new_names
-
- select_one :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Name
- -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)])
- select_one (rules, decls) name
- = case lookupNameEnv rules name of
- Nothing -> (rules, decls)
- Just gated_rules -> foldl filter_rule (delFromNameEnv rules name, decls) gated_rules
-
- filter_rule :: (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)]) -> Gated IfaceRule
- -> (NameEnv [Gated IfaceRule], [(ModuleName, IfaceRule)])
- filter_rule (rules, decls) (rule_fvs, rule)
- = case [fv | fv <- rule_fvs, not (fv `elemNameEnv` type_env)] of
- [] -> -- No remaining FVs, so slurp it
- (rules, rule:decls)
- fvs -> -- There leftover fvs, so toss it back in the pool
- (addRuleToPool rules rule fvs, decls)
+ (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,
-- Check for type consistency in the unfolding
ifOptM Opt_DoCoreLinting (
- case lintUnfolding noSrcLoc [{- in scope -}] core_expr' of
+ get_in_scope_ids `thenM` \ in_scope ->
+ case lintUnfolding noSrcLoc in_scope core_expr' of
Nothing -> returnM ()
Just fail_msg -> pprPanic "Iface Lint failure" (doc <+> fail_msg)
) `thenM_`
returnM core_expr'
where
doc = text "Unfolding of" <+> ppr name
+ get_in_scope_ids -- Urgh; but just for linting
+ = setLclEnv () $
+ do { env <- getGblEnv
+ ; case if_rec_types env of {
+ Nothing -> return [] ;
+ Just (_, get_env) -> do
+ { type_env <- get_env
+ ; return (typeEnvIds type_env) }}}
\end{code}
projects / ghc-hetmet.git / blobdiff