\begin{code}
module TcIface (
- tcImportDecl, typecheckIface,
- tcIfaceKind, loadImportedInsts,
+ tcImportDecl, typecheckIface, tcIfaceDecl, tcIfaceGlobal,
+ loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
#include "HsVersions.h"
import IfaceSyn
-import LoadIface ( loadHomeInterface, predInstGates )
-import IfaceEnv ( lookupIfaceTop, newGlobalBinder, lookupOrig,
+import LoadIface ( loadHomeInterface, predInstGates, discardDeclPrags )
+import IfaceEnv ( lookupIfaceTop, lookupIfaceExt, newGlobalBinder, lookupOrig,
extendIfaceIdEnv, extendIfaceTyVarEnv, newIPName,
- tcIfaceTyVar, tcIfaceTyCon, tcIfaceClass, tcIfaceExtId,
- tcIfaceDataCon, tcIfaceLclId,
+ tcIfaceTyVar, tcIfaceLclId,
newIfaceName, newIfaceNames )
-import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass )
+import BuildTyCl ( buildSynTyCon, buildAlgTyCon, buildDataCon, buildClass,
+ mkAbstractTyConRhs, mkDataTyConRhs, mkNewTyConRhs )
import TcRnMonad
-import Type ( Kind, openTypeKind, liftedTypeKind,
- unliftedTypeKind, mkArrowKind, splitTyConApp,
- mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
+import Type ( liftedTypeKind, splitTyConApp,
+ mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType, pprClassPred )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
-import HscTypes ( ExternalPackageState(..), PackageInstEnv,
- TyThing(..), implicitTyThings, typeEnvIds,
- ModIface(..), ModDetails(..), InstPool,
- TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
- DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
+import HscTypes ( ExternalPackageState(..), EpsStats(..), PackageInstEnv,
+ HscEnv, TyThing(..), implicitTyThings, tyThingClass, tyThingTyCon,
+ ModIface(..), ModDetails(..), ModGuts,
+ mkTypeEnv, extendTypeEnv,
+ lookupTypeEnv, lookupType, typeEnvIds )
import InstEnv ( extendInstEnv )
import CoreSyn
+import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
import CoreUtils ( exprType )
import CoreUnfold
setArityInfo, setInlinePragInfo, setCafInfo,
vanillaIdInfo, newStrictnessInfo )
import Class ( Class )
-import TyCon ( DataConDetails(..), tyConDataCons, tyConTyVars, isTupleTyCon, mkForeignTyCon )
-import DataCon ( dataConWorkId, dataConExistentialTyVars, dataConArgTys )
-import TysWiredIn ( tupleCon )
+import TyCon ( tyConDataCons, isTupleTyCon, mkForeignTyCon )
+import DataCon ( DataCon, dataConWorkId, dataConTyVars, dataConArgTys, isVanillaDataCon )
+import TysWiredIn ( tupleCon, tupleTyCon, listTyCon, intTyCon, boolTyCon, charTyCon, parrTyCon )
import Var ( TyVar, mkTyVar, tyVarKind )
-import Name ( Name, NamedThing(..), nameModuleName, nameModule, nameOccName,
+import Name ( Name, nameModule, nameIsLocalOrFrom,
isWiredInName, wiredInNameTyThing_maybe, nameParent )
import NameEnv
import OccName ( OccName )
-import Module ( Module, ModuleName, moduleName )
+import Module ( Module )
import UniqSupply ( initUs_ )
import Outputable
import SrcLoc ( noSrcLoc )
-import Util ( zipWithEqual, dropList, equalLength )
-import Maybes ( expectJust )
+import Util ( zipWithEqual, dropList, equalLength, zipLazy )
import CmdLineOpts ( DynFlag(..) )
\end{code}
tcImportDecl :: Name -> IfG TyThing
-- Get the TyThing for this Name from an interface file
tcImportDecl name
- = do {
- -- Make sure the interface is loaded
- ; let { nd_doc = ptext SLIT("Need decl for") <+> ppr name }
- ; 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-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)
-
- -- Get the decl out of the EPS
- ; main_thing <- ASSERT( real_name == name ) -- Unique should not change!
- getThing real_name
-
- -- Record the import in the type env,
- -- slurp any rules it allows in
- ; recordImportOf main_thing
-
- ; 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 <+> char '}')
-
-
- -- Look up the wanted Name in the type envt; it might be
- -- one of the subordinate members of the input thing
- ; if real_name == getName main_thing
- then return main_thing
- else do
- { eps <- getEps
- ; return (expectJust "tcImportDecl" $
- lookupTypeEnv (eps_PTE eps) real_name) }}
-
-recordImportOf :: TyThing -> IfG ()
--- Update the EPS to record the import of the Thing
--- (a) augment the type environment; this is done even for wired-in
--- things, so that we don't go through this rigmarole a second time
--- (b) slurp in any rules to maintain the invariant that any rule
--- whose gates are all in the type envt, is in eps_rule_base
-
-recordImportOf thing
- = do { (new_things, iface_rules) <- 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!
- -- If working out what the implicitTyThings are involves poking
- -- any of the fork'd thunks in 'thing', then here's what happens
- -- * recordImportOf succeed, extending type-env with a thunk
- -- * the next guy to pull on type-env forces the thunk
- -- * 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))
- )
-
- -- Now type-check those rules (which may side-effect the EPS again)
- ; traceIf (text "tcImport: extend type env" <+> ppr new_things)
- ; traceIf (text "tcImport: rules" <+> vcat (map ppr iface_rules))
- ; 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)
--- The Thing we return is the parent "main thing"
-
-getThing name
| Just thing <- wiredInNameTyThing_maybe name
- = return thing
-
- | 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) }
-
-
-selectDecl :: DeclPool -> Name -> (DeclPool, 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)
- 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
+ -- This case only happens for tuples, because we pre-populate the eps_PTE
+ -- with other wired-in things. We can't do that for tuples because we
+ -- don't know how many of them we'll find
+ = do { updateEps_ (\ eps -> eps { eps_PTE = extendTypeEnv (eps_PTE eps) thing })
+ ; return thing }
+
+ | otherwise
+ = do { traceIf nd_doc
+
+ -- Load the interface, which should populate the PTE
+ ; loadHomeInterface nd_doc name
+
+ -- Now look it up again; this time we should find it
+ ; eps <- getEps
+ ; case lookupTypeEnv (eps_PTE eps) name of
+ Just thing -> return thing
+ 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
+ nd_doc = ptext SLIT("Need decl for") <+> ppr name
+ 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")])
\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)
- ; dfuns <- mapM tcIfaceInst (mi_insts iface)
- ; return (ModDetails { md_types = mkTypeEnv ty_things,
- md_insts = dfuns,
- md_rules = rules }) }
+typecheckIface :: HscEnv
+ -> ModIface -- Get the decls from here
+ -> IO ModDetails
+typecheckIface hsc_env iface
+ = initIfaceTc hsc_env iface $ \ tc_env_var -> do
+ { -- Get the right set of decls and rules. If we are compiling without -O
+ -- we discard pragmas before typechecking, so that we don't "see"
+ -- information that we shouldn't. From a versioning point of view
+ -- It's not actually *wrong* to do so, but in fact GHCi is unable
+ -- to handle unboxed tuples, so it must not see unfoldings.
+ ignore_prags <- doptM Opt_IgnoreInterfacePragmas
+ ; let { decls | ignore_prags = map (discardDeclPrags . snd) (mi_decls iface)
+ | otherwise = map snd (mi_decls iface)
+ ; rules | ignore_prags = []
+ | otherwise = mi_rules iface
+ ; dfuns = mi_insts iface
+ ; mod = mi_module iface
+ }
+ -- Typecheck the decls
+ ; names <- mappM (lookupOrig 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 dfuns
+ ; rules <- mapM tcIfaceRule rules
+
+ -- Finished
+ ; return (ModDetails { md_types = type_env, md_insts = dfuns, md_rules = rules })
+ }
\end{code}
; info <- tcIdInfo name ty info
; return (AnId (mkVanillaGlobal name ty info)) }
-tcIfaceDecl (IfaceData {ifND = new_or_data, ifName = occ_name,
- ifTyVars = tv_bndrs, ifCtxt = rdr_ctxt,
+tcIfaceDecl (IfaceData {ifName = occ_name,
+ ifTyVars = tv_bndrs,
ifCons = rdr_cons,
ifVrcs = arg_vrcs, ifRec = is_rec,
ifGeneric = want_generic })
= do { tc_name <- lookupIfaceTop occ_name
; bindIfaceTyVars tv_bndrs $ \ tyvars -> do
- { traceIf (text "tcIfaceDecl" <+> ppr rdr_ctxt)
-
- ; ctxt <- forkM (ptext SLIT("Ctxt of data decl") <+> ppr tc_name) $
- tcIfaceCtxt rdr_ctxt
- -- The reason for laziness here is to postpone
- -- looking at the context, because the class may not
- -- be in the type envt yet. E.g.
- -- class Real a where { toRat :: a -> Ratio Integer }
- -- data (Real a) => Ratio a = ...
- -- We suck in the decl for Real, and type check it, which sucks
- -- in the data type Ratio; but we must postpone typechecking the
- -- context
-
- ; tycon <- fixM ( \ tycon -> do
- { cons <- tcIfaceDataCons tycon tyvars ctxt rdr_cons
- ; tycon <- buildAlgTyCon new_or_data tc_name tyvars ctxt cons
+ { tycon <- fixM ( \ tycon -> do
+ { cons <- tcIfaceDataCons tycon tyvars rdr_cons
+ ; tycon <- buildAlgTyCon tc_name tyvars cons
arg_vrcs is_rec want_generic
; return tycon
})
; traceIf (text "tcIfaceDecl4" <+> ppr tycon)
; return (ATyCon tycon)
- } }
+ }}
tcIfaceDecl (IfaceSyn {ifName = occ_name, ifTyVars = tv_bndrs,
ifSynRhs = rdr_rhs_ty, ifVrcs = arg_vrcs})
; return (ATyCon (mkForeignTyCon name ext_name
liftedTypeKind 0 [])) }
-tcIfaceDataCons tycon tyvars ctxt Unknown
- = returnM Unknown
-
-tcIfaceDataCons tycon tyvars ctxt (DataCons cs)
- = mappM tc_con_decl cs `thenM` \ data_cons ->
- returnM (DataCons data_cons)
+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) }
where
- tc_con_decl (IfaceConDecl occ ex_tvs ex_ctxt args stricts field_lbls)
- = bindIfaceTyVars ex_tvs $ \ ex_tyvars -> do
- { name <- lookupIfaceTop occ
- ; ex_theta <- tcIfaceCtxt ex_ctxt -- Laziness seems not worth the bother here
+ 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
+ -- Read the argument types, but lazily to avoid faulting in
+ -- the component types unless they are really needed
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; lbl_names <- mappM lookupIfaceTop field_lbls
+ ; buildDataCon name is_infix True {- Vanilla -}
+ stricts lbl_names
+ tc_tyvars [] arg_tys tycon
+ (mkTyVarTys tc_tyvars) -- Vanilla => we know result tys
+ }
+
+ tc_con_decl (IfGadtCon { ifConTyVars = con_tvs,
+ ifConOcc = occ, ifConCtxt = ctxt,
+ ifConArgTys = args, ifConResTys = ress,
+ ifConStricts = stricts})
+ = bindIfaceTyVars con_tvs $ \ con_tyvars -> do
+ { name <- lookupIfaceTop occ
+ ; theta <- tcIfaceCtxt ctxt -- Laziness seems not worth the bother here
+ -- At one stage I thought that this context checking *had*
+ -- to be lazy, because of possible mutual recursion between the
+ -- type and the classe:
+ -- E.g.
+ -- class Real a where { toRat :: a -> Ratio Integer }
+ -- data (Real a) => Ratio a = ...
+ -- But now I think that the laziness in checking class ops breaks
+ -- the loop, so no laziness needed
-- Read the argument types, but lazily to avoid faulting in
-- the component types unless they are really needed
- ; arg_tys <- forkM (mk_doc name args) (mappM tcIfaceType args) ;
+ ; arg_tys <- forkM (mk_doc name) (mappM tcIfaceType args)
+ ; res_tys <- forkM (mk_doc name) (mappM tcIfaceType ress)
- ; lbl_names <- mappM lookupIfaceTop field_lbls
-
- ; buildDataCon name stricts lbl_names
- tyvars ctxt ex_tyvars ex_theta
- arg_tys tycon
+ ; buildDataCon name False {- Not infix -} False {- Not vanilla -}
+ stricts [{- No fields -}]
+ con_tyvars theta
+ arg_tys tycon res_tys
}
- mk_doc con_name args = ptext SLIT("Constructor") <+> sep [ppr con_name, ppr args]
+ mk_doc con_name = ptext SLIT("Constructor") <+> ppr con_name
\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
; if null wired_tcs then returnM ()
else initIfaceTcRn (mapM_ (loadHomeInterface wired_doc) wired_tcs)
- ; eps_var <- getEpsVar
- ; eps <- readMutVar eps_var
-
- -- Suck in the instances
- ; let { (inst_pool', iface_insts)
- = selectInsts (eps_insts eps) cls_gate tc_gates }
+ -- 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
- return (eps_inst_env eps)
+ do { eps <- getEps; return (eps_inst_env eps) }
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)
tcIfaceInst (IfaceInst { ifDFun = dfun_occ })
= tcIfaceExtId (LocalTop dfun_occ)
-selectInsts :: InstPool -> Name -> [Name] -> (InstPool, [(ModuleName, IfaceInst)])
-selectInsts pool@(Pool insts n_in n_out) cls tycons
- = (Pool insts' n_in (n_out + length iface_insts), iface_insts)
+selectInsts :: Name -> [Name] -> ExternalPackageState -> (ExternalPackageState, [(Module, IfaceInst)])
+selectInsts cls tycons eps
+ = (eps { eps_insts = insts', eps_stats = stats' }, iface_insts)
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 ->
+ 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 [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 (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.
+ ; return core_rules
+ }
+
+
+selectRules :: ExternalPackageState -> (ExternalPackageState, [(Module, 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
- (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)
+ 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,
do { fn <- tcIfaceExtId fn_rdr
; args' <- mappM tcIfaceExpr args
; rhs' <- tcIfaceExpr rhs
- ; returnM (fn, (Rule rule_name act bndrs' args' rhs')) }
+ ; let rule = Rule rule_name act bndrs' args' rhs'
+ ; returnM (IdCoreRule fn (isOrphNm fn_rdr) rule) }
+ where
tcIfaceRule (IfaceBuiltinRule fn_rdr core_rule)
= do { fn <- tcIfaceExtId fn_rdr
- ; returnM (fn, core_rule) }
+ ; returnM (IdCoreRule fn (isOrphNm fn_rdr) core_rule) }
+
+isOrphNm :: IfaceExtName -> Bool
+isOrphNm (LocalTop _) = False
+isOrphNm (LocalTopSub _ _) = False
+isOrphNm other = True
\end{code}
%************************************************************************
\begin{code}
-tcIfaceKind :: IfaceKind -> Kind
-tcIfaceKind IfaceOpenTypeKind = openTypeKind
-tcIfaceKind IfaceLiftedTypeKind = liftedTypeKind
-tcIfaceKind IfaceUnliftedTypeKind = unliftedTypeKind
-tcIfaceKind (IfaceFunKind k1 k2) = mkArrowKind (tcIfaceKind k1) (tcIfaceKind k2)
-
------------------------------------------
tcIfaceType :: IfaceType -> IfL Type
tcIfaceType (IfaceTyVar n) = do { tv <- tcIfaceTyVar n; return (TyVarTy tv) }
tcIfaceType (IfaceAppTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (AppTy t1' t2') }
tcIfaceExpr arg `thenM` \ arg' ->
returnM (App fun' arg')
-tcIfaceExpr (IfaceCase scrut case_bndr alts)
+-- gaw 2004
+tcIfaceExpr (IfaceCase scrut case_bndr ty alts)
= tcIfaceExpr scrut `thenM` \ scrut' ->
newIfaceName case_bndr `thenM` \ case_bndr_name ->
let
in
extendIfaceIdEnv [case_bndr'] $
mappM (tcIfaceAlt tc_app) alts `thenM` \ alts' ->
- returnM (Case scrut' case_bndr' alts')
+ tcIfaceType ty `thenM` \ ty' ->
+ returnM (Case scrut' case_bndr' ty' alts')
tcIfaceExpr (IfaceLet (IfaceNonRec bndr rhs) body)
= tcIfaceExpr rhs `thenM` \ rhs' ->
-- by the fact that we omit type annotations because we can
-- work them out. True enough, but its not that easy!
tcIfaceAlt (tycon, inst_tys) (IfaceDataAlt data_occ, arg_occs, rhs)
- = let
- tycon_mod = nameModuleName (tyConName tycon)
- in
- tcIfaceDataCon (ExtPkg tycon_mod data_occ) `thenM` \ con ->
- newIfaceNames arg_occs `thenM` \ arg_names ->
- let
- ex_tyvars = dataConExistentialTyVars con
- main_tyvars = tyConTyVars tycon
- ex_tyvars' = [mkTyVar name (tyVarKind tv) | (name,tv) <- arg_names `zip` ex_tyvars]
- ex_tys' = mkTyVarTys ex_tyvars'
- arg_tys = dataConArgTys con (inst_tys ++ ex_tys')
- id_names = dropList ex_tyvars arg_names
- arg_ids
-#ifdef DEBUG
- | not (equalLength id_names arg_tys)
- = pprPanic "tcIfaceAlts" (ppr (con, arg_names, rhs) $$
- (ppr main_tyvars <+> ppr ex_tyvars) $$
- ppr arg_tys)
- | otherwise
-#endif
- = zipWithEqual "tcIfaceAlts" mkLocalId id_names arg_tys
- in
- ASSERT2( con `elem` tyConDataCons tycon && equalLength inst_tys main_tyvars,
- ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) $$ ppr arg_tys $$ ppr main_tyvars )
- extendIfaceTyVarEnv ex_tyvars' $
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DataAlt con, ex_tyvars' ++ arg_ids, rhs')
+ = do { let tycon_mod = nameModule (tyConName tycon)
+ ; con <- tcIfaceDataCon (ExtPkg tycon_mod data_occ)
+ ; ASSERT2( con `elem` tyConDataCons tycon,
+ ppr con $$ ppr tycon $$ ppr (tyConDataCons tycon) )
+
+ if isVanillaDataCon con then
+ tcVanillaAlt con inst_tys arg_occs rhs
+ else
+ do { -- General case
+ arg_names <- newIfaceNames arg_occs
+ ; let tyvars = [ mkTyVar name (tyVarKind tv)
+ | (name,tv) <- arg_names `zip` dataConTyVars con]
+ arg_tys = dataConArgTys con (mkTyVarTys tyvars)
+ id_names = dropList tyvars arg_names
+ arg_ids = ASSERT2( equalLength id_names arg_tys,
+ ppr (con, arg_names, rhs) $$ ppr tyvars $$ ppr arg_tys )
+ zipWith mkLocalId id_names arg_tys
+
+ ; rhs' <- extendIfaceTyVarEnv tyvars $
+ extendIfaceIdEnv arg_ids $
+ tcIfaceExpr rhs
+ ; return (DataAlt con, tyvars ++ arg_ids, rhs') }}
tcIfaceAlt (tycon, inst_tys) (IfaceTupleAlt boxity, arg_occs, rhs)
- = newIfaceNames arg_occs `thenM` \ arg_names ->
- let
- [con] = tyConDataCons tycon
- arg_ids = zipWithEqual "tcIfaceAlts" mkLocalId arg_names inst_tys
- in
- ASSERT( isTupleTyCon tycon )
- extendIfaceIdEnv arg_ids $
- tcIfaceExpr rhs `thenM` \ rhs' ->
- returnM (DataAlt con, arg_ids, rhs')
+ = ASSERT( isTupleTyCon tycon )
+ do { let [data_con] = tyConDataCons tycon
+ ; tcVanillaAlt data_con inst_tys arg_occs rhs }
+
+tcVanillaAlt data_con inst_tys arg_occs rhs
+ = do { arg_names <- newIfaceNames arg_occs
+ ; let arg_tys = dataConArgTys data_con inst_tys
+ ; let arg_ids = ASSERT2( equalLength arg_names arg_tys,
+ ppr data_con <+> ppr inst_tys <+> ppr arg_occs $$ ppr rhs )
+ zipWith mkLocalId arg_names arg_tys
+ ; rhs' <- extendIfaceIdEnv arg_ids (tcIfaceExpr rhs)
+ ; returnM (DataAlt data_con, arg_ids, rhs') }
\end{code}
%************************************************************************
\begin{code}
-tcIdInfo name ty NoInfo = return vanillaIdInfo
-tcIdInfo name ty DiscardedInfo = return vanillaIdInfo
-tcIdInfo name ty (HasInfo iface_info)
- = foldlM tcPrag init_info iface_info
+tcIdInfo :: Name -> Type -> IfaceIdInfo -> IfL IdInfo
+tcIdInfo name ty NoInfo = return vanillaIdInfo
+tcIdInfo name ty (HasInfo info) = foldlM tcPrag init_info info
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
\end{code}
\begin{code}
-tcWorkerInfo ty info wkr_name arity
- = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId (LocalTop wkr_name))
+tcWorkerInfo ty info wkr arity
+ = do { mb_wkr_id <- forkM_maybe doc (tcIfaceExtId wkr)
-- We return without testing maybe_wkr_id, but as soon as info is
-- looked at we will test it. That's ok, because its outside the
Nothing -> info
Just wkr_id -> add_wkr_info us wkr_id info) }
where
- doc = text "Worker for" <+> ppr wkr_name
+ doc = text "Worker for" <+> ppr wkr
add_wkr_info us wkr_id info
= info `setUnfoldingInfoLazily` mk_unfolding us wkr_id
`setWorkerInfo` HasWorker wkr_id arity
-- before worker info, fingers crossed ....
strict_sig = case newStrictnessInfo info of
Just sig -> sig
- Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr_name)
+ Nothing -> pprPanic "Worker info but no strictness for" (ppr wkr)
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
%************************************************************************
%* *
+ Getting from Names to TyThings
+%* *
+%************************************************************************
+
+\begin{code}
+tcIfaceGlobal :: Name -> IfM a TyThing
+tcIfaceGlobal name
+ = do { (eps,hpt) <- getEpsAndHpt
+ ; case lookupType hpt (eps_PTE eps) name of {
+ Just thing -> return thing ;
+ Nothing ->
+
+ setLclEnv () $ do -- This gets us back to IfG, mainly to
+ -- pacify get_type_env; rather untidy
+ { env <- getGblEnv
+ ; case if_rec_types env of
+ Just (mod, get_type_env)
+ | nameIsLocalOrFrom mod name
+ -> do -- It's defined in the module being compiled
+ { type_env <- get_type_env
+ ; case lookupNameEnv type_env name of
+ Just thing -> return thing
+ Nothing -> pprPanic "tcIfaceGlobal (local): not found:"
+ (ppr name $$ ppr type_env) }
+
+ other -> tcImportDecl name -- It's imported; go get it
+ }}}
+
+tcIfaceTyCon :: IfaceTyCon -> IfL TyCon
+tcIfaceTyCon IfaceIntTc = return intTyCon
+tcIfaceTyCon IfaceBoolTc = return boolTyCon
+tcIfaceTyCon IfaceCharTc = return charTyCon
+tcIfaceTyCon IfaceListTc = return listTyCon
+tcIfaceTyCon IfacePArrTc = return parrTyCon
+tcIfaceTyCon (IfaceTupTc bx ar) = return (tupleTyCon bx ar)
+tcIfaceTyCon (IfaceTc ext_nm) = do { name <- lookupIfaceExt ext_nm
+ ; thing <- tcIfaceGlobal name
+ ; return (tyThingTyCon thing) }
+
+tcIfaceClass :: IfaceExtName -> IfL Class
+tcIfaceClass rdr_name = do { name <- lookupIfaceExt rdr_name
+ ; thing <- tcIfaceGlobal name
+ ; return (tyThingClass thing) }
+
+tcIfaceDataCon :: IfaceExtName -> IfL DataCon
+tcIfaceDataCon gbl = do { name <- lookupIfaceExt gbl
+ ; thing <- tcIfaceGlobal name
+ ; case thing of
+ ADataCon dc -> return dc
+ other -> pprPanic "tcIfaceExtDC" (ppr gbl $$ ppr name$$ ppr thing) }
+
+tcIfaceExtId :: IfaceExtName -> IfL Id
+tcIfaceExtId gbl = do { name <- lookupIfaceExt gbl
+ ; thing <- tcIfaceGlobal name
+ ; case thing of
+ AnId id -> return id
+ other -> pprPanic "tcIfaceExtId" (ppr gbl $$ ppr name$$ ppr thing) }
+\end{code}
+
+%************************************************************************
+%* *
Bindings
%* *
%************************************************************************
where
(occs,kinds) = unzip bndrs
-mk_iface_tyvar name kind = mkTyVar name (tcIfaceKind kind)
+mk_iface_tyvar name kind = mkTyVar name kind
\end{code}
+
projects / ghc-hetmet.git / blobdiff