From 8575cfe27f04474172a2b244bd5a575b4cbe735c Mon Sep 17 00:00:00 2001 From: simonpj Date: Fri, 10 Oct 2003 09:39:34 +0000 Subject: [PATCH] [project @ 2003-10-10 09:39:33 by simonpj] Make rule importing work properly --- ghc/compiler/iface/LoadIface.lhs | 12 ++--- ghc/compiler/iface/TcIface.lhs | 85 +++++++++++++++++----------------- ghc/compiler/main/HscTypes.lhs | 30 +++++------- ghc/compiler/simplCore/SimplCore.lhs | 5 +- 4 files changed, 63 insertions(+), 69 deletions(-) diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index 9110575..1db091f 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -29,7 +29,7 @@ import HscTypes ( HscEnv(..), ModIface(..), emptyModIface, lookupIfaceByModName, emptyPackageIfaceTable, IsBootInterface, mkIfaceFixCache, Pool(..), DeclPool, InstPool, - RulePool, Gated, addRuleToPool + RulePool, Gated, addRuleToPool, RulePoolContents ) import BasicTypes ( Version, Fixity(..), FixityDirection(..) ) @@ -371,7 +371,7 @@ loadRules mod pool@(Pool rule_pool n_in n_out) rules { 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}) @@ -590,9 +590,9 @@ initExternalPackageState 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 @@ -640,7 +640,7 @@ ifaceStats eps 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", diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 92c8d38..5fc5399 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -6,7 +6,7 @@ \begin{code} module TcIface ( tcImportDecl, typecheckIface, - tcIfaceKind, loadImportedInsts, + tcIfaceKind, loadImportedInsts, loadImportedRules, tcExtCoreBindings ) where #include "HsVersions.h" @@ -25,13 +25,14 @@ import Type ( Kind, openTypeKind, liftedTypeKind, 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 @@ -152,7 +153,7 @@ recordImportOf :: TyThing -> IfG () -- 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! @@ -163,24 +164,12 @@ recordImportOf thing -- * 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) @@ -503,30 +492,42 @@ are in the type environment. However, remember that typechecking a Rule may (as a side effect) augment the type envt, and so we may need to iterate the process. \begin{code} -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, diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 7cb86bf..113c386 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -39,7 +39,7 @@ module HscTypes ( Dependencies(..), noDependencies, Pool(..), emptyPool, DeclPool, InstPool, Gated, - RulePool, addRuleToPool, + RulePool, RulePoolContents, addRuleToPool, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availName, availNames, GenAvailInfo(..), AvailInfo, RdrAvailInfo, @@ -739,14 +739,7 @@ data ExternalPackageState -- 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} @@ -777,36 +770,35 @@ type OrigIParamCache = FiniteMap (IPName OccName) (IPName Name) \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 diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index af78fb7..28e0b91 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -14,6 +14,7 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), ) import CoreSyn import CoreFVs ( ruleRhsFreeVars ) +import TcIface ( loadImportedRules ) import HscTypes ( HscEnv(..), GhciMode(..), ModGuts(..), ModGuts, Avails, availsToNameSet, ModDetails(..), @@ -224,7 +225,7 @@ prepareRules :: HscEnv prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) us binds local_rules - = do { eps <- hscEPS hsc_env + = do { pkg_rule_base <- loadImportedRules hsc_env ; let env = emptySimplEnv SimplGently [] local_ids (better_rules,_) = initSmpl dflags us (mapSmpl (simplRule env) local_rules) @@ -242,7 +243,7 @@ prepareRules hsc_env@(HscEnv { hsc_dflags = dflags, hsc_HPT = hpt }) local_rule_base = extendRuleBaseList emptyRuleBase local_rules local_rule_ids = ruleBaseIds local_rule_base -- Local Ids with rules attached - imp_rule_base = foldl add_rules (eps_rule_base eps) (moduleEnvElts hpt) + imp_rule_base = foldl add_rules pkg_rule_base (moduleEnvElts hpt) final_rule_base = extendRuleBaseList imp_rule_base orphan_rules ; dumpIfSet_dyn dflags Opt_D_dump_rules "Transformation rules" -- 1.7.10.4