Commit 0cb1f5cf authored by Edward Z. Yang's avatar Edward Z. Yang

Filter orphan rules based on imports, fixes #10294 and #10420.

Summary:
If we have an orphan rule in our database, don't apply it
unless the defining module is transitively imported by the
module we are processing.  We do this by defining a new RuleEnv
data type which includes both the RuleBase as well as the set
of visible orphan modules, and threading this through the
relevant environments (CoreReader, RuleCheckEnv and ScEnv).

This is analogous to the instances fix we applied in #2182
4c834fdd, but done for RULES.
An important knock-on effect is that we can remove some buggy
code in LoadInterface which tried to avoid loading interfaces
that were loaded by plugins (which sometimes caused instances
and rules to NEVER become visible).

One note about tests: I renamed the old plugins07 test to T10420
and replaced plugins07 with a test to ensure that a plugin
import did not cause new rules to be loaded in.
Signed-off-by: default avatarEdward Z. Yang <ezyang@cs.stanford.edu>

Test Plan: validate

Reviewers: simonpj, austin, goldfire

Subscribers: bgamari, thomie

Differential Revision: https://phabricator.haskell.org/D950

GHC Trac Issues: #10420
parent 85d53975
......@@ -24,7 +24,7 @@ module CoreFVs (
idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars,
idRuleVars, idRuleRhsVars, stableUnfoldingVars,
ruleRhsFreeVars, ruleFreeVars, rulesFreeVars,
ruleLhsOrphNames, ruleLhsFreeIds,
ruleLhsOrphNames, ruleLhsFreeIds, exprsOrphNames,
vectsFreeVars,
-- * Core syntax tree annotation with free variables
......
......@@ -1871,6 +1871,7 @@ withoutAnnots pass guts = do
withoutFlag corem =
liftIO =<< runCoreM <$> fmap removeFlag getHscEnv <*> getRuleBase <*>
getUniqueSupplyM <*> getModule <*>
getVisibleOrphanMods <*>
getPrintUnqualified <*> pure corem
-- Nuke existing ticks in module.
-- TODO: Ticks in unfoldings. Maybe change unfolding so it removes
......
......@@ -67,9 +67,13 @@ module CoreSyn (
-- ** Operations on annotations
deAnnotate, deAnnotate', deAnnAlt, collectAnnBndrs,
-- * Orphanhood
IsOrphan(..), isOrphan, notOrphan,
-- * Core rule data types
CoreRule(..), RuleBase,
RuleName, RuleFun, IdUnfoldingFun, InScopeEnv,
RuleEnv(..), mkRuleEnv, emptyRuleEnv,
-- ** Operations on 'CoreRule's
ruleArity, ruleName, ruleIdName, ruleActivation,
......@@ -88,7 +92,7 @@ import Var
import Type
import Coercion
import Name
import NameEnv( NameEnv )
import NameEnv( NameEnv, emptyNameEnv )
import Literal
import DataCon
import Module
......@@ -99,6 +103,7 @@ import FastString
import Outputable
import Util
import SrcLoc ( RealSrcSpan, containsSpan )
import Binary
import Data.Data hiding (TyCon)
import Data.Int
......@@ -690,6 +695,84 @@ tickishContains (SourceNote sp1 n1) (SourceNote sp2 n2)
tickishContains t1 t2
= t1 == t2
{-
************************************************************************
* *
Orphans
* *
************************************************************************
-}
-- | Is this instance an orphan? If it is not an orphan, contains an 'OccName'
-- witnessing the instance's non-orphanhood.
-- See Note [Orphans]
data IsOrphan
= IsOrphan
| NotOrphan OccName -- The OccName 'n' witnesses the instance's non-orphanhood
-- In that case, the instance is fingerprinted as part
-- of the definition of 'n's definition
deriving (Data, Typeable)
-- | Returns true if 'IsOrphan' is orphan.
isOrphan :: IsOrphan -> Bool
isOrphan IsOrphan = True
isOrphan _ = False
-- | Returns true if 'IsOrphan' is not an orphan.
notOrphan :: IsOrphan -> Bool
notOrphan NotOrphan{} = True
notOrphan _ = False
instance Binary IsOrphan where
put_ bh IsOrphan = putByte bh 0
put_ bh (NotOrphan n) = do
putByte bh 1
put_ bh n
get bh = do
h <- getByte bh
case h of
0 -> return IsOrphan
_ -> do
n <- get bh
return $ NotOrphan n
{-
Note [Orphans]
~~~~~~~~~~~~~~
Class instances, rules, and family instances are divided into orphans
and non-orphans. Roughly speaking, an instance/rule is an orphan if
its left hand side mentions nothing defined in this module. Orphan-hood
has two major consequences
* A module that contains orphans is called an "orphan module". If
the module being compiled depends (transitively) on an oprhan
module M, then M.hi is read in regardless of whether M is oherwise
needed. This is to ensure that we don't miss any instance decls in
M. But it's painful, because it means we need to keep track of all
the orphan modules below us.
* A non-orphan is not finger-printed separately. Instead, for
fingerprinting purposes it is treated as part of the entity it
mentions on the LHS. For example
data T = T1 | T2
instance Eq T where ....
The instance (Eq T) is incorprated as part of T's fingerprint.
In constrast, orphans are all fingerprinted together in the
mi_orph_hash field of the ModIface.
See MkIface.addFingerprints.
Orphan-hood is computed
* For class instances:
when we make a ClsInst
(because it is needed during instance lookup)
* For rules and family instances:
when we generate an IfaceRule (MkIface.coreRuleToIfaceRule)
or IfaceFamInst (MkIface.instanceToIfaceInst)
-}
{-
************************************************************************
* *
......@@ -706,6 +789,20 @@ type RuleBase = NameEnv [CoreRule]
-- The rules are unordered;
-- we sort out any overlaps on lookup
-- | A full rule environment which we can apply rules from. Like a 'RuleBase',
-- but it also includes the set of visible orphans we use to filter out orphan
-- rules which are not visible (even though we can see them...)
data RuleEnv
= RuleEnv { re_base :: RuleBase
, re_visible_orphs :: ModuleSet
}
mkRuleEnv :: RuleBase -> [Module] -> RuleEnv
mkRuleEnv rules vis_orphs = RuleEnv rules (mkModuleSet vis_orphs)
emptyRuleEnv :: RuleEnv
emptyRuleEnv = RuleEnv emptyNameEnv emptyModuleSet
-- | A 'CoreRule' is:
--
-- * \"Local\" if the function it is a rule for is defined in the
......@@ -738,17 +835,26 @@ data CoreRule
-- @False@ <=> generated at the users behest
-- Main effect: reporting of orphan-hood
ru_origin :: !Module, -- ^ 'Module' the rule was defined in, used
-- to test if we should see an orphan rule.
ru_orphan :: !IsOrphan,
-- ^ Whether or not the rule is an orphan.
ru_local :: Bool -- ^ @True@ iff the fn at the head of the rule is
-- defined in the same module as the rule
-- and is not an implicit 'Id' (like a record selector,
-- class operation, or data constructor)
-- NB: ru_local is *not* used to decide orphan-hood
-- c.g. MkIface.coreRuleToIfaceRule
-- class operation, or data constructor). This
-- is different from 'ru_orphan', where a rule
-- can avoid being an orphan if *any* Name in
-- LHS of the rule was defined in the same
-- module as the rule.
}
-- | Built-in rules are used for constant folding
-- and suchlike. They have no free variables.
-- A built-in rule is always visible (there is no such thing as
-- an orphan built-in rule.)
| BuiltinRule {
ru_name :: RuleName, -- ^ As above
ru_fn :: Name, -- ^ As above
......
......@@ -356,6 +356,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
; rhs' <- dsLExpr rhs
; dflags <- getDynFlags
; this_mod <- getModule
; (bndrs'', lhs'', rhs'') <- unfold_coerce bndrs' lhs' rhs'
......@@ -371,7 +372,7 @@ dsRule (L loc (HsRule name act vars lhs _tv_lhs rhs _fv_rhs))
-- because they don't show up in the bindings until just before code gen
fn_name = idName fn_id
final_rhs = simpleOptExpr rhs'' -- De-crap it
rule = mkRule False {- Not auto -} is_local
rule = mkRule this_mod False {- Not auto -} is_local
(snd $ unLoc name) act fn_name final_bndrs args
final_rhs
......
......@@ -444,6 +444,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
Right (rule_bndrs, _fn, args) -> do
{ dflags <- getDynFlags
; this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
unf_fvs = stableUnfoldingVars fn_unf `orElse` emptyVarSet
in_scope = mkInScopeSet (unf_fvs `unionVarSet` exprsFreeVars args)
......@@ -451,7 +452,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
rule = mkRule False {- Not auto -} is_local_id
rule = mkRule this_mod False {- Not auto -} is_local_id
(mkFastString ("SPEC " ++ showPpr dflags poly_name))
rule_act poly_name
rule_bndrs args
......
......@@ -458,11 +458,7 @@ loadInterface doc_str mod from
; updateEps_ $ \ eps ->
if elemModuleEnv mod (eps_PIT eps) then eps else
case from of -- See Note [Care with plugin imports]
ImportByPlugin -> eps {
eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls}
_ -> eps {
eps {
eps_PIT = extendModuleEnv (eps_PIT eps) mod final_iface,
eps_PTE = addDeclsToPTE (eps_PTE eps) new_eps_decls,
eps_rule_base = extendRuleBaseList (eps_rule_base eps)
......@@ -526,27 +522,6 @@ badSourceImport mod
2 (ptext (sLit "but") <+> quotes (ppr mod) <+> ptext (sLit "is from package")
<+> quotes (ppr (modulePackageKey mod)))
{-
Note [Care with plugin imports]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When dynamically loading a plugin (via loadPluginInterface) we
populate the same External Package State (EPS), even though plugin
modules are to link with the compiler itself, and not with the
compiled program. That's fine: mostly the EPS is just a cache for
the interace files on disk.
But it's NOT ok for the RULES or instance environment. We do not want
to fire a RULE from the plugin on the code we are compiling, otherwise
the code we are compiling will have a reference to a RHS of the rule
that exists only in the compiler! This actually happened to Daniel,
via a RULE arising from a specialisation of (^) in the plugin.
Solution: when loading plugins, do not extend the rule and instance
environments. We are only interested in the type environment, so that
we can check that the plugin exports a function with the type that the
compiler expects.
-}
-----------------------------------------------------
-- Loading type/class/value decls
-- We pass the full Module name here, replete with
......
......@@ -69,7 +69,6 @@ import Demand
import Coercion( tidyCo )
import Annotations
import CoreSyn
import CoreFVs
import Class
import Kind
import TyCon
......@@ -271,7 +270,7 @@ mkIface_ hsc_env maybe_old_fingerprint
fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env]
warns = src_warns
iface_rules = map (coreRuleToIfaceRule this_mod) rules
iface_rules = map coreRuleToIfaceRule rules
iface_insts = map instanceToIfaceInst $ fixSafeInstances safe_mode insts
iface_fam_insts = map famInstToIfaceFamInst fam_insts
iface_vect_info = flattenVectInfo vect_info
......@@ -1929,15 +1928,15 @@ toIfUnfolding _ _
= Nothing
--------------------------
coreRuleToIfaceRule :: Module -> CoreRule -> IfaceRule
coreRuleToIfaceRule _ (BuiltinRule { ru_fn = fn})
coreRuleToIfaceRule :: CoreRule -> IfaceRule
coreRuleToIfaceRule (BuiltinRule { ru_fn = fn})
= pprTrace "toHsRule: builtin" (ppr fn) $
bogusIfaceRule fn
coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
ru_args = args, ru_rhs = rhs,
ru_auto = auto })
coreRuleToIfaceRule (Rule { ru_name = name, ru_fn = fn,
ru_act = act, ru_bndrs = bndrs,
ru_args = args, ru_rhs = rhs,
ru_orphan = orph, ru_auto = auto })
= IfaceRule { ifRuleName = name, ifActivation = act,
ifRuleBndrs = map toIfaceBndr bndrs,
ifRuleHead = fn,
......@@ -1954,15 +1953,6 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
do_arg (Coercion co) = IfaceCo (toIfaceCoercion co)
do_arg arg = toIfaceExpr arg
-- Compute orphanhood. See Note [Orphans] in InstEnv
-- A rule is an orphan only if none of the variables
-- mentioned on its left-hand side are locally defined
lhs_names = nameSetElems (ruleLhsOrphNames rule)
orph = case filter (nameIsLocalOrFrom mod) lhs_names of
(n : _) -> NotOrphan (nameOccName n)
[] -> IsOrphan
bogusIfaceRule :: Name -> IfaceRule
bogusIfaceRule id_name
= IfaceRule { ifRuleName = fsLit "bogus", ifActivation = NeverActive,
......
......@@ -625,7 +625,7 @@ tcIfaceRules ignore_prags if_rules
tcIfaceRule :: IfaceRule -> IfL CoreRule
tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs,
ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs,
ifRuleAuto = auto })
ifRuleAuto = auto, ifRuleOrph = orph })
= do { ~(bndrs', args', rhs') <-
-- Typecheck the payload lazily, in the hope it'll never be looked at
forkM (ptext (sLit "Rule") <+> ftext name) $
......@@ -634,10 +634,13 @@ tcIfaceRule (IfaceRule {ifRuleName = name, ifActivation = act, ifRuleBndrs = bnd
; rhs' <- tcIfaceExpr rhs
; return (bndrs', args', rhs') }
; let mb_tcs = map ifTopFreeName args
; this_mod <- getIfModule
; return (Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs', ru_args = args',
ru_rhs = occurAnalyseExpr rhs',
ru_rough = mb_tcs,
ru_origin = this_mod,
ru_orphan = orph,
ru_auto = auto,
ru_local = False }) } -- An imported RULE is never for a local Id
-- or, even if it is (module loop, perhaps)
......
......@@ -27,6 +27,7 @@ module CoreMonad (
-- ** Reading from the monad
getHscEnv, getRuleBase, getModule,
getDynFlags, getOrigNameCache, getPackageFamInstEnv,
getVisibleOrphanMods,
getPrintUnqualified,
-- ** Writing to the monad
......@@ -518,6 +519,7 @@ data CoreReader = CoreReader {
cr_hsc_env :: HscEnv,
cr_rule_base :: RuleBase,
cr_module :: Module,
cr_visible_orphan_mods :: !ModuleSet,
cr_print_unqual :: PrintUnqualified,
#ifdef GHCI
cr_globals :: (MVar PersistentLinkerState, Bool)
......@@ -595,10 +597,11 @@ runCoreM :: HscEnv
-> RuleBase
-> UniqSupply
-> Module
-> ModuleSet
-> PrintUnqualified
-> CoreM a
-> IO (a, SimplCount)
runCoreM hsc_env rule_base us mod print_unqual m = do
runCoreM hsc_env rule_base us mod orph_imps print_unqual m = do
glbls <- saveLinkerGlobals
liftM extract $ runIOEnv (reader glbls) $ unCoreM m state
where
......@@ -606,6 +609,7 @@ runCoreM hsc_env rule_base us mod print_unqual m = do
cr_hsc_env = hsc_env,
cr_rule_base = rule_base,
cr_module = mod,
cr_visible_orphan_mods = orph_imps,
cr_globals = glbls,
cr_print_unqual = print_unqual
}
......@@ -668,6 +672,9 @@ getHscEnv = read cr_hsc_env
getRuleBase :: CoreM RuleBase
getRuleBase = read cr_rule_base
getVisibleOrphanMods :: CoreM ModuleSet
getVisibleOrphanMods = read cr_visible_orphan_mods
getPrintUnqualified :: CoreM PrintUnqualified
getPrintUnqualified = read cr_print_unqual
......
......@@ -14,7 +14,7 @@ import DynFlags
import CoreSyn
import HscTypes
import CSE ( cseProgram )
import Rules ( emptyRuleBase, mkRuleBase, unionRuleBase,
import Rules ( mkRuleBase, unionRuleBase,
extendRuleBaseList, ruleCheckProgram, addSpecInfo, )
import PprCore ( pprCoreBindings, pprCoreExpr )
import OccurAnal ( occurAnalysePgm, occurAnalyseExpr )
......@@ -47,6 +47,7 @@ import Vectorise ( vectorise )
import FastString
import SrcLoc
import Util
import Module
import Maybes
import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply )
......@@ -72,8 +73,10 @@ core2core hsc_env guts
-- make sure all plugins are loaded
; let builtin_passes = getCoreToDo dflags
orph_mods = mkModuleSet (mg_module guts : dep_orphs (mg_deps guts))
;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod
orph_mods print_unqual $
do { all_passes <- addPluginPasses builtin_passes
; runCorePasses all_passes guts }
......@@ -411,9 +414,11 @@ ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts
ruleCheckPass current_phase pat guts = do
rb <- getRuleBase
dflags <- getDynFlags
vis_orphs <- getVisibleOrphanMods
liftIO $ Err.showPass dflags "RuleCheck"
liftIO $ log_action dflags dflags Err.SevDump noSrcSpan defaultDumpStyle
(ruleCheckProgram current_phase pat rb (mg_binds guts))
(ruleCheckProgram current_phase pat
(RuleEnv rb vis_orphs) (mg_binds guts))
return guts
......@@ -490,8 +495,9 @@ simplifyExpr dflags expr
; let sz = exprSize expr
; (expr', counts) <- initSmpl dflags emptyRuleBase emptyFamInstEnvs us sz $
simplExprGently (simplEnvForGHCi dflags) expr
; (expr', counts) <- initSmpl dflags emptyRuleEnv
emptyFamInstEnvs us sz
(simplExprGently (simplEnvForGHCi dflags) expr)
; Err.dumpIfSet dflags (dopt Opt_D_dump_simpl_stats dflags)
"Simplifier statistics" (pprSimplCount counts)
......@@ -551,6 +557,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
hsc_env us hpt_rule_base
guts@(ModGuts { mg_module = this_mod
, mg_rdr_env = rdr_env
, mg_deps = deps
, mg_binds = binds, mg_rules = rules
, mg_fam_inst_env = fam_inst_env })
= do { (termination_msg, it_count, counts_out, guts')
......@@ -639,10 +646,12 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
eps <- hscEPS hsc_env ;
let { rule_base1 = unionRuleBase hpt_rule_base (eps_rule_base eps)
; rule_base2 = extendRuleBaseList rule_base1 rules
; fam_envs = (eps_fam_inst_env eps, fam_inst_env) } ;
; fam_envs = (eps_fam_inst_env eps, fam_inst_env)
; vis_orphs = this_mod : dep_orphs deps } ;
-- Simplify the program
((binds1, rules1), counts1) <- initSmpl dflags rule_base2 fam_envs us1 sz $
((binds1, rules1), counts1) <-
initSmpl dflags (mkRuleEnv rule_base2 vis_orphs) fam_envs us1 sz $
do { env1 <- {-# SCC "SimplTopBinds" #-}
simplTopBinds simpl_env tagged_binds
......
......@@ -22,7 +22,7 @@ module SimplMonad (
import Id ( Id, mkSysLocal )
import Type ( Type )
import FamInstEnv ( FamInstEnv )
import CoreSyn ( RuleBase )
import CoreSyn ( RuleEnv(..) )
import UniqSupply
import DynFlags
import CoreMonad
......@@ -55,10 +55,10 @@ newtype SimplM result
data SimplTopEnv
= STE { st_flags :: DynFlags
, st_max_ticks :: IntWithInf -- Max #ticks in this simplifier run
, st_rules :: RuleBase
, st_rules :: RuleEnv
, st_fams :: (FamInstEnv, FamInstEnv) }
initSmpl :: DynFlags -> RuleBase -> (FamInstEnv, FamInstEnv)
initSmpl :: DynFlags -> RuleEnv -> (FamInstEnv, FamInstEnv)
-> UniqSupply -- No init count; set to 0
-> Int -- Size of the bindings, used to limit
-- the number of ticks we allow
......@@ -168,7 +168,7 @@ instance MonadIO SimplM where
x <- m
return (x, us, sc)
getSimplRules :: SimplM RuleBase
getSimplRules :: SimplM RuleEnv
getSimplRules = SM (\st_env us sc -> return (st_rules st_env, us, sc))
getFamEnvs :: SimplM (FamInstEnv, FamInstEnv)
......
......@@ -29,9 +29,11 @@ module Rules (
#include "HsVersions.h"
import CoreSyn -- All of it
import Module ( Module, ModuleSet, elemModuleSet )
import CoreSubst
import OccurAnal ( occurAnalyseExpr )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars, rulesFreeVars )
import CoreFVs ( exprFreeVars, exprsFreeVars, bindFreeVars
, rulesFreeVars, exprsOrphNames )
import CoreUtils ( exprType, eqExpr, mkTick, mkTicks,
stripTicksTopT, stripTicksTopE )
import PprCore ( pprRules )
......@@ -43,7 +45,8 @@ import Id
import IdInfo ( SpecInfo( SpecInfo ) )
import VarEnv
import VarSet
import Name ( Name, NamedThing(..) )
import Name ( Name, NamedThing(..), nameIsLocalOrFrom, nameOccName )
import NameSet
import NameEnv
import Unify ( ruleMatchTyX, MatchEnv(..) )
import BasicTypes ( Activation, CompilerPhase, isActive )
......@@ -158,16 +161,28 @@ might have a specialisation
where pi' :: Lift Int# is the specialised version of pi.
-}
mkRule :: Bool -> Bool -> RuleName -> Activation
mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
-> Name -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'CoreSyn.CoreRule'
mkRule is_auto is_local name act fn bndrs args rhs
mkRule this_mod is_auto is_local name act fn bndrs args rhs
= Rule { ru_name = name, ru_fn = fn, ru_act = act,
ru_bndrs = bndrs, ru_args = args,
ru_rhs = occurAnalyseExpr rhs,
ru_rough = roughTopNames args,
ru_origin = this_mod,
ru_orphan = orph,
ru_auto = is_auto, ru_local = is_local }
where
-- Compute orphanhood. See Note [Orphans] in InstEnv
-- A rule is an orphan only if none of the variables
-- mentioned on its left-hand side are locally defined
lhs_names = nameSetElems (extendNameSet (exprsOrphNames args) fn)
-- TODO: copied from ruleLhsOrphNames
orph = case filter (nameIsLocalOrFrom this_mod) lhs_names of
(n : _) -> NotOrphan (nameOccName n)
[] -> IsOrphan
--------------
roughTopNames :: [CoreExpr] -> [Maybe Name]
......@@ -277,13 +292,18 @@ addIdSpecialisations id rules
rulesOfBinds :: [CoreBind] -> [CoreRule]
rulesOfBinds binds = concatMap (concatMap idCoreRules . bindersOf) binds
getRules :: RuleBase -> Id -> [CoreRule]
getRules :: RuleEnv -> Id -> [CoreRule]
-- See Note [Where rules are found]
getRules rule_base fn
= idCoreRules fn ++ imp_rules
getRules (RuleEnv { re_base = rule_base, re_visible_orphs = orphs }) fn
= idCoreRules fn ++ filter (ruleIsVisible orphs) imp_rules
where
imp_rules = lookupNameEnv rule_base (idName fn) `orElse` []
ruleIsVisible :: ModuleSet -> CoreRule -> Bool
ruleIsVisible _ BuiltinRule{} = True
ruleIsVisible vis_orphs Rule { ru_orphan = orph, ru_origin = origin }
= notOrphan orph || origin `elemModuleSet` vis_orphs
{-
Note [Where rules are found]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -1041,7 +1061,7 @@ is so important.
-- string for the purposes of error reporting
ruleCheckProgram :: CompilerPhase -- ^ Rule activation test
-> String -- ^ Rule pattern
-> RuleBase -- ^ Database of rules
-> RuleEnv -- ^ Database of rules
-> CoreProgram -- ^ Bindings to check in
-> SDoc -- ^ Resulting check message
ruleCheckProgram phase rule_pat rule_base binds
......@@ -1065,7 +1085,7 @@ data RuleCheckEnv = RuleCheckEnv {
rc_is_active :: Activation -> Bool,
rc_id_unf :: IdUnfoldingFun,
rc_pattern :: String,
rc_rule_base :: RuleBase
rc_rule_base :: RuleEnv
}
ruleCheckBind :: RuleCheckEnv -> CoreBind -> Bag SDoc
......
......@@ -58,6 +58,7 @@ import MonadUtils
import Control.Monad ( zipWithM )
import Data.List
import PrelNames ( specTyConName )
import Module
-- See Note [Forcing specialisation]
#ifndef GHCI
......@@ -686,9 +687,11 @@ specConstrProgram guts
dflags <- getDynFlags
us <- getUniqueSupplyM
annos <- getFirstAnnotations deserializeWithData guts
this_mod <- getModule
let binds' = reverse $ fst $ initUs us $ do
-- Note [Top-level recursive groups]
(env, binds) <- goEnv (initScEnv dflags annos) (mg_binds guts)
(env, binds) <- goEnv (initScEnv dflags this_mod annos)
(mg_binds guts)
-- binds is identical to (mg_binds guts), except that the
-- binders on the LHS have been replaced by extendBndr
-- (SPJ this seems like overkill; I don't think the binders
......@@ -760,6 +763,7 @@ leave it for now.
-}
data ScEnv = SCE { sc_dflags :: DynFlags,
sc_module :: !Module,
sc_size :: Maybe Int, -- Size threshold
sc_count :: Maybe Int, -- Max # of specialisations for any one fn
-- See Note [Avoiding exponential blowup]
......@@ -811,9 +815,10 @@ instance Outputable Value where
ppr LambdaVal = ptext (sLit "<Lambda>")
---------------------
initScEnv :: DynFlags -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv dflags anns
initScEnv :: DynFlags -> Module -> UniqFM SpecConstrAnnotation -> ScEnv
initScEnv dflags this_mod anns
= SCE { sc_dflags = dflags,
sc_module = this_mod,
sc_size = specConstrThreshold dflags,
sc_count = specConstrCount dflags,
sc_recursive = specConstrRecursive dflags,
......@@ -1650,7 +1655,8 @@ spec_one env fn arg_bndrs body (call_pat@(qvars, pats), rule_number)
body_ty = exprType spec_body
rule_rhs = mkVarApps (Var spec_id) spec_call_args
inline_act = idInlineActivation fn
rule = mkRule True {- Auto -} True {- Local -}
this_mod = sc_module spec_env
rule = mkRule this_mod True {- Auto -} True {- Local -}
rule_name inline_act fn_name qvars pats rule_rhs
-- See Note [Transfer activation]
; return (spec_usg, OS call_pat rule spec_id spec_rhs) }
......
......@@ -13,7 +13,7 @@ import Id
import TcType hiding( substTy, extendTvSubstList )
import Type hiding( substTy, extendTvSubstList )
import Coercion( Coercion )
import Module( Module )
import Module( Module, HasModule(..) )
import CoreMonad
import qualified CoreSubst
import CoreUnfold
......@@ -578,7 +578,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
= do { dflags <- getDynFlags
-- Specialise the bindings of this module
; (binds', uds) <- runSpecM dflags (go binds)
; (binds', uds) <- runSpecM dflags this_mod (go binds)
-- Specialise imported functions
; hpt_rules <- getRuleBase
......@@ -652,10 +652,11 @@ specImport dflags this_mod done rb fn calls_for_fn
-- more rules as we go along
; hsc_env <- getHscEnv
; eps <- liftIO $ hscEPS hsc_env
; vis_orphs <- getVisibleOrphanMods
; let full_rb = unionRuleBase rb (eps_rule_base eps)
rules_for_fn = getRules full_rb fn
rules_for_fn = getRules (RuleEnv full_rb vis_orphs) fn
; (rules1, spec_pairs, uds) <- runSpecM dflags $
; (rules1, spec_pairs, uds) <- runSpecM dflags this_mod $
specCalls (Just this_mod) emptySpecEnv rules_for_fn calls_for_fn fn rhs
; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
-- After the rules kick in we may get recursion, but
......@@ -1187,6 +1188,7 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
; spec_f <- newSpecIdSM fn spec_id_ty
; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_args body)
; this_mod <- getModule
; let
-- The rule to put in the function's specialisation is:
-- forall b, d1',d2'. f t1 b t3 d1' d2' = f1 b
......@@ -1202,7 +1204,10 @@ specCalls mb_mod env rules_for_me calls_for_me fn rhs
-- otherwise uniques end up there, making builds
-- less deterministic (See #4012 comment:61 ff)
spec_env_rule = mkRule True {- Auto generated -} is_local
spec_env_rule = mkRule
this_mod
True {- Auto generated -}
is_local
rule_name
inl_act -- Note [Auto-specialisation and RULES]
(idName fn)
......@@ -1955,6 +1960,7 @@ newtype SpecM a = SpecM (State SpecState a)
data SpecState = SpecState {
spec_uniq_supply :: UniqSupply,
spec_module :: Module,
spec_dflags :: DynFlags
}
......@@ -1989,11 +1995,15 @@ instance MonadUnique SpecM where
instance HasDynFlags SpecM where
getDynFlags = SpecM $ liftM spec_dflags get
runSpecM :: DynFlags -> SpecM a -> CoreM a
runSpecM dflags (SpecM spec)
instance HasModule SpecM where
getModule = SpecM $ liftM spec_module get
runSpecM :: DynFlags -> Module -> SpecM a -> CoreM a
runSpecM dflags this_mod (SpecM spec)
= do us <- getUniqueSupplyM
let initialState = SpecState {
spec_uniq_supply = us,
spec_module = this_mod,
spec_dflags = dflags