Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Sign in / Register
Toggle navigation
Menu
Open sidebar
Glasgow Haskell Compiler
GHC
Commits
8575cfe2
Commit
8575cfe2
authored
Oct 10, 2003
by
simonpj
Browse files
[project @ 2003-10-10 09:39:33 by simonpj]
Make rule importing work properly
parent
ac395860
Changes
4
Hide whitespace changes
Inline
Side-by-side
ghc/compiler/iface/LoadIface.lhs
View file @
8575cfe2
...
...
@@ -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",
...
...
ghc/compiler/iface/TcIface.lhs
View file @
8575cfe2
...
...
@@ -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,
...
...
ghc/compiler/main/HscTypes.lhs
View file @
8575cfe2
...
...
@@ -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
IfaceD
ecl
type DeclPool = Pool
(NameEnv IfaceDecl) -- Keyed by the "main thing" of the d
ecl
-------------------------
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
...
...
ghc/compiler/simplCore/SimplCore.lhs
View file @
8575cfe2
...
...
@@ -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"
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new file
.
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment