diff options
Diffstat (limited to 'compiler')
| -rw-r--r-- | compiler/coreSyn/CoreFVs.hs | 2 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreLint.hs | 1 | ||||
| -rw-r--r-- | compiler/coreSyn/CoreSyn.hs | 116 | ||||
| -rw-r--r-- | compiler/deSugar/Desugar.hs | 3 | ||||
| -rw-r--r-- | compiler/deSugar/DsBinds.hs | 3 | ||||
| -rw-r--r-- | compiler/iface/LoadIface.hs | 27 | ||||
| -rw-r--r-- | compiler/iface/MkIface.hs | 24 | ||||
| -rw-r--r-- | compiler/iface/TcIface.hs | 5 | ||||
| -rw-r--r-- | compiler/simplCore/CoreMonad.hs | 9 | ||||
| -rw-r--r-- | compiler/simplCore/SimplCore.hs | 23 | ||||
| -rw-r--r-- | compiler/simplCore/SimplMonad.hs | 8 | ||||
| -rw-r--r-- | compiler/specialise/Rules.hs | 38 | ||||
| -rw-r--r-- | compiler/specialise/SpecConstr.hs | 14 | ||||
| -rw-r--r-- | compiler/specialise/Specialise.hs | 24 | ||||
| -rw-r--r-- | compiler/types/InstEnv.hs | 78 |
15 files changed, 214 insertions, 161 deletions
diff --git a/compiler/coreSyn/CoreFVs.hs b/compiler/coreSyn/CoreFVs.hs index 2a44ccc9a3..688728ae48 100644 --- a/compiler/coreSyn/CoreFVs.hs +++ b/compiler/coreSyn/CoreFVs.hs @@ -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 diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 989cb7f7bf..f681ea53ac 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -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 diff --git a/compiler/coreSyn/CoreSyn.hs b/compiler/coreSyn/CoreSyn.hs index 98400c42a3..c641d88f65 100644 --- a/compiler/coreSyn/CoreSyn.hs +++ b/compiler/coreSyn/CoreSyn.hs @@ -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 @@ -693,6 +698,84 @@ tickishContains 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) +-} + +{- +************************************************************************ +* * \subsection{Transformation rules} * * ************************************************************************ @@ -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 diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 2e84560f9e..e3a31b9caa 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -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 diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs index fac5eb7d0a..ab3dfb90e1 100644 --- a/compiler/deSugar/DsBinds.hs +++ b/compiler/deSugar/DsBinds.hs @@ -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 diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index 60feb04a4f..2a8943ca11 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -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 diff --git a/compiler/iface/MkIface.hs b/compiler/iface/MkIface.hs index c1a9d2523f..970031327c 100644 --- a/compiler/iface/MkIface.hs +++ b/compiler/iface/MkIface.hs @@ -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, diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs index 7d6d1a6aa7..4f80fc9c4e 100644 --- a/compiler/iface/TcIface.hs +++ b/compiler/iface/TcIface.hs @@ -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) diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index dec41bb4f7..fc69fdc681 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -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 diff --git a/compiler/simplCore/SimplCore.hs b/compiler/simplCore/SimplCore.hs index d83ab89bd6..88ca00f6a0 100644 --- a/compiler/simplCore/SimplCore.hs +++ b/compiler/simplCore/SimplCore.hs @@ -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 diff --git a/compiler/simplCore/SimplMonad.hs b/compiler/simplCore/SimplMonad.hs index bd60a7942c..c8503a7f3f 100644 --- a/compiler/simplCore/SimplMonad.hs +++ b/compiler/simplCore/SimplMonad.hs @@ -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) diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index 3601253e41..cb71e3a3f3 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -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 diff --git a/compiler/specialise/SpecConstr.hs b/compiler/specialise/SpecConstr.hs index 7a4b4028c4..a8c6f060ab 100644 --- a/compiler/specialise/SpecConstr.hs +++ b/compiler/specialise/SpecConstr.hs @@ -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) } diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 61633f9834..5c29c28449 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -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 } return $ evalState spec initialState diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 6151f20599..f810850d4b 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -29,6 +29,7 @@ module InstEnv ( #include "HsVersions.h" +import CoreSyn (IsOrphan(..), isOrphan, notOrphan) import Module import Class import Var @@ -44,7 +45,6 @@ import BasicTypes import UniqFM import Util import Id -import Binary import FastString import Data.Data ( Data, Typeable ) import Data.Maybe ( isJust, isNothing ) @@ -274,82 +274,6 @@ instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as instanceCantMatch _ _ = False -- Safe {- -************************************************************************ -* * - 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) - Note [When exactly is an instance decl an orphan?] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ (see MkIface.instanceToIfaceInst, which implements this) |