lookupIfaceByModName, emptyPackageIfaceTable,
IsBootInterface, mkIfaceFixCache,
Pool(..), DeclPool, InstPool,
- RulePool, Gated, addRuleToPool
+ RulePool, Gated, addRuleToPool, RulePoolContents
)
import BasicTypes ( Version, Fixity(..), FixityDirection(..) )
{ new_pool <- foldlM (loadRule (moduleName mod)) rule_pool rules
; returnM (Pool new_pool (n_in + length rules) n_out) } }
-loadRule :: ModuleName -> NameEnv [Gated IfaceRule] -> IfaceRule -> IfL (NameEnv [Gated IfaceRule])
+loadRule :: ModuleName -> RulePoolContents -> IfaceRule -> IfL RulePoolContents
-- "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 mod_name pool decl@(IfaceRule {ifRuleHead = fn, ifRuleArgs = args})
eps_PTE = emptyTypeEnv,
eps_inst_env = emptyInstEnv,
eps_rule_base = emptyRuleBase,
- eps_decls = emptyPool,
- eps_insts = emptyPool,
- eps_rules = foldr add emptyPool builtinRules
+ eps_decls = emptyPool emptyNameEnv,
+ eps_insts = emptyPool emptyNameEnv,
+ eps_rules = foldr add (emptyPool []) builtinRules
}
where
-- Initialise the EPS rule pool with the built-in rules
Pool _ n_decls_in n_decls_out = eps_decls eps
Pool _ n_insts_in n_insts_out = eps_insts eps
- Pool _ n_rules_in n_rules_out = eps_rules eps
+ Pool _ n_rules_in n_rules_out = eps_rules eps
stats = vcat
[int n_mods <+> text "interfaces read",
\begin{code}
module TcIface (
tcImportDecl, typecheckIface,
- tcIfaceKind, loadImportedInsts,
+ tcIfaceKind, loadImportedInsts, loadImportedRules,
tcExtCoreBindings
) where
#include "HsVersions.h"
mkTyVarTys, mkGenTyConApp, mkTyVarTys, ThetaType )
import TypeRep ( Type(..), PredType(..) )
import TyCon ( TyCon, tyConName )
-import HscTypes ( ExternalPackageState(..), PackageInstEnv,
- TyThing(..), implicitTyThings, typeEnvIds,
+import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase,
+ HscEnv, TyThing(..), implicitTyThings, typeEnvIds,
ModIface(..), ModDetails(..), InstPool,
TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv,
DeclPool, RulePool, Pool(..), Gated, addRuleToPool )
import InstEnv ( extendInstEnv )
import CoreSyn
+import PprCore ( pprIdRules )
import Rules ( extendRuleBaseList )
import CoreUtils ( exprType )
import CoreUnfold
-- 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)
- ; 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)
(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 -> IO PackageRuleBase
+loadImportedRules hsc_env
+ = initIfaceIO hsc_env $ 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) )
+
+ ; let tc_rule (mod, rule) = initIfaceLcl mod (tcIfaceRule rule)
+ ; core_rules <- mapM tc_rule if_rules
+
+ -- Debug print
+ ; traceIf (ptext SLIT("Importing 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)
+ ) }
+
+
+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 (`elemNameEnv` type_env) gates
+
tcIfaceRule :: IfaceRule -> IfL IdCoreRule
tcIfaceRule (IfaceRule {ifRuleName = rule_name, ifActivation = act, ifRuleBndrs = bndrs,
Dependencies(..), noDependencies,
Pool(..), emptyPool, DeclPool, InstPool,
Gated,
- RulePool, addRuleToPool,
+ RulePool, RulePoolContents, addRuleToPool,
NameCache(..), OrigNameCache, OrigIParamCache,
Avails, availsToNameSet, availName, availNames,
GenAvailInfo(..), AvailInfo, RdrAvailInfo,
-- available before this instance decl is needed.
eps_rules :: !RulePool
- -- Rules move from here to eps_rule_base when
- -- all their LHS free vars are in the eps_PTE
- -- To maintain this invariant, we need to check the pool
- -- a) when adding to the rule pool by loading an interface
- -- (some of the new rules may alrady have all their
- -- gates in the eps_PTE)
- -- b) when extending the eps_PTE when we load a decl
- -- from the eps_decls pool
+ -- The as-yet un-slurped rules
}
\end{code}
\end{code}
\begin{code}
-data Pool p = Pool (NameEnv p) -- The pool itself, indexed by some primary key
+data Pool p = Pool p -- The pool itself
Int -- Number of decls slurped into the map
Int -- Number of decls slurped out of the map
-emptyPool = Pool emptyNameEnv 0 0
+emptyPool p = Pool p 0 0
instance Outputable p => Outputable (Pool p) where
ppr (Pool p n_in n_out) -- Debug printing only
= vcat [ptext SLIT("Pool") <+> int n_in <+> int n_out,
nest 2 (ppr p)]
-type DeclPool = Pool IfaceDecl
+type DeclPool = Pool (NameEnv IfaceDecl) -- Keyed by the "main thing" of the decl
-------------------------
type Gated d = ([Name], (ModuleName, d)) -- The [Name] 'gate' the declaration
-- ModuleName records which iface file this
-- decl came from
-type RulePool = Pool [Gated IfaceRule]
+type RulePool = Pool RulePoolContents
+type RulePoolContents = [Gated IfaceRule]
-addRuleToPool :: NameEnv [Gated IfaceRule]
+addRuleToPool :: RulePoolContents
-> (ModuleName, IfaceRule)
-> [Name] -- Free vars of rule; always non-empty
- -> NameEnv [Gated IfaceRule]
-addRuleToPool rules rule (fv:fvs) = extendNameEnv_C combine rules fv [(fvs,rule)]
- where
- combine old _ = (fvs,rule) : old
+ -> RulePoolContents
+addRuleToPool rules rule fvs = (fvs,rule) : rules
-------------------------
-type InstPool = Pool [Gated IfaceInst]
+type InstPool = Pool (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
projects / ghc-hetmet.git / commitdiff