diff options
| -rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 86 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T22715_2.hs | 6 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T22715_2a.hs | 29 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 2 |
4 files changed, 87 insertions, 36 deletions
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index dda10da34e..fa9323ab3b 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -33,6 +33,7 @@ import GHC.Core.Utils ( exprIsTrivial import GHC.Core.FVs import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList ) import GHC.Core.Opt.Arity( collectBindersPushingCo ) +-- import GHC.Core.Ppr( pprIds ) import GHC.Builtin.Types ( unboxedUnitTy ) @@ -736,7 +737,8 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) = return ([], wrapDictBinds dict_binds []) | otherwise - = do { (_env, spec_rules, spec_binds) <- spec_imports top_env [] dict_binds calls + = do { let env_w_dict_bndrs = top_env `bringFloatedDictsIntoScope` dict_binds + ; (_env, spec_rules, spec_binds) <- spec_imports env_w_dict_bndrs [] dict_binds calls -- Don't forget to wrap the specialized bindings with -- bindings for the needed dictionaries. @@ -752,6 +754,7 @@ specImports top_env (MkUD { ud_binds = dict_binds, ud_calls = calls }) -- | Specialise a set of calls to imported bindings spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in scope + ---In-scope set includes the FloatedDictBinds -> [Id] -- Stack of imported functions being specialised -- See Note [specImport call stack] -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls @@ -781,6 +784,7 @@ spec_imports env callers dict_binds calls ; return (env, rules1 ++ rules2, spec_binds1 ++ spec_binds2) } spec_import :: SpecEnv -- Passed in so that all top-level Ids are in scope + ---In-scope set includes the FloatedDictBinds -> [Id] -- Stack of imported functions being specialised -- See Note [specImport call stack] -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls @@ -806,23 +810,35 @@ spec_import env callers dict_binds cis@(CIS fn _) ; eps_rules <- getExternalRuleBase ; let rule_env = se_rules env `updExternalPackageRules` eps_rules --- ; debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls --- , ppr (getRules rule_env fn), ppr rhs]) +-- ; debugTraceMsg (text "specImport1" <+> vcat +-- [ text "function:" <+> ppr fn +-- , text "good calls:" <+> ppr good_calls +-- , text "existing rules:" <+> ppr (getRules rule_env fn) +-- , text "rhs:" <+> ppr rhs +-- , text "dict_binds:" <+> ppr dict_binds ]) + ; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls }) - <- runSpecM $ specCalls True env dict_binds - (getRules rule_env fn) good_calls fn rhs + <- runSpecM $ specCalls True env (getRules rule_env fn) good_calls fn rhs ; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs] - -- After the rules kick in we may get recursion, but - -- we rely on a global GlomBinds to sort that out later + -- After the rules kick in, via fireRewriteRules, we may get recursion, + -- but we rely on a global GlomBinds to sort that out later -- See Note [Glom the bindings if imported functions are specialised] + -- Meanwhile, though, bring the binders into scope new_subst = se_subst env `Core.extendSubstInScopeList` map fst spec_pairs new_env = env { se_rules = rule_env `addLocalRules` rules1 , se_subst = new_subst } + `bringFloatedDictsIntoScope` dict_binds1 + + -- Now specialise any cascaded calls +-- ; debugTraceMsg (text "specImport 2" <+> vcat +-- [ text "function:" <+> ppr fn +-- , text "rules1:" <+> ppr rules1 +-- , text "spec_binds1" <+> ppr spec_binds1 +-- , text "dict_binds1" <+> ppr dict_binds1 +-- , text "new_calls" <+> ppr new_calls ]) - -- Now specialise any cascaded calls --- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1)) ; (env, rules2, spec_binds2) <- spec_imports new_env (fn:callers) (dict_binds `thenFDBs` dict_binds1) @@ -1561,10 +1577,11 @@ specDefn :: SpecEnv specDefn env body_uds fn rhs = do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds rules_for_me = idCoreRules fn - dict_binds = ud_binds body_uds + -- Bring into scope the binders from the floated dicts + env_w_dict_bndrs = bringFloatedDictsIntoScope env (ud_binds body_uds) - ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds - rules_for_me calls_for_me fn rhs + ; (rules, spec_defns, spec_uds) <- specCalls False env_w_dict_bndrs + rules_for_me calls_for_me fn rhs ; return ( fn `addIdSpecialisations` rules , spec_defns @@ -1580,7 +1597,6 @@ specDefn env body_uds fn rhs specCalls :: Bool -- True => specialising imported fn -- False => specialising local fn -> SpecEnv - -> FloatedDictBinds -- Just so that we can extend the in-scope set -> [CoreRule] -- Existing RULES for the fn -> [CallInfo] -> OutId -> InExpr @@ -1594,7 +1610,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules , [(Id,CoreExpr)] -- Specialised definition , UsageDetails ) -- Usage details from specialised RHSs -specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs +specCalls spec_imp env existing_rules calls_for_me fn rhs -- The first case is the interesting one | notNull calls_for_me -- And there are some calls to specialise && not (isNeverActive (idInlineActivation fn)) @@ -1610,8 +1626,11 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs -- See Note [Inline specialisations] for why we do not -- switch off specialisation for inline functions - = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $ - foldlM spec_call ([], [], emptyUDs) calls_for_me + = do { -- debugTraceMsg (text "specCalls: some" <+> vcat + -- [ text "function" <+> ppr fn + -- , text "calls:" <+> ppr calls_for_me + -- , text "subst" <+> ppr (se_subst env) ]) + ; foldlM spec_call ([], [], emptyUDs) calls_for_me } | otherwise -- No calls or RHS doesn't fit our preconceptions = warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me && not (isClassOpId fn)) @@ -1639,9 +1658,6 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] - -- Bring into scope the binders from the floated dicts - env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds - already_covered :: SpecEnv -> [CoreRule] -> [CoreExpr] -> Bool already_covered env new_rules args -- Note [Specialisations already covered] = isJust (specLookupRule env fn args (beginPhase inl_act) @@ -1667,22 +1683,22 @@ specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs ; ( useful, rhs_env2, leftover_bndrs , rule_bndrs, rule_lhs_args - , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs - rhs_bndrs all_call_args - --- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn --- , text "call info: " <+> ppr _ci --- , text "useful: " <+> ppr useful --- , text "rule_bndrs:" <+> ppr rule_bndrs --- , text "lhs_args: " <+> ppr rule_lhs_args --- , text "spec_bndrs1:" <+> ppr spec_bndrs1 --- , text "leftover_bndrs:" <+> pprIds leftover_bndrs --- , text "spec_args: " <+> ppr spec_args --- , text "dx_binds: " <+> ppr dx_binds --- , text "rhs_body" <+> ppr rhs_body --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) --- , ppr dx_binds ]) $ --- return () + , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args + +-- ; debugTraceMsg (text "spec_call" <+> vcat +-- [ text "fun: " <+> ppr fn +-- , text "call info: " <+> ppr _ci +-- , text "useful: " <+> ppr useful +-- , text "rule_bndrs:" <+> ppr rule_bndrs +-- , text "lhs_args: " <+> ppr rule_lhs_args +-- , text "spec_bndrs1:" <+> ppr spec_bndrs1 +-- , text "leftover_bndrs:" <+> pprIds leftover_bndrs +-- , text "spec_args: " <+> ppr spec_args +-- , text "dx_binds: " <+> ppr dx_binds +-- , text "rhs_bndrs" <+> ppr rhs_bndrs +-- , text "rhs_body" <+> ppr rhs_body +-- , text "rhs_env2: " <+> ppr (se_subst rhs_env2) +-- , ppr dx_binds ] ; if not useful -- No useful specialisation || already_covered rhs_env2 rules_acc rule_lhs_args diff --git a/testsuite/tests/simplCore/should_compile/T22715_2.hs b/testsuite/tests/simplCore/should_compile/T22715_2.hs new file mode 100644 index 0000000000..4001f92c30 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T22715_2.hs @@ -0,0 +1,6 @@ +module T22715_2 where + +import T22715_2a + +debugTerminalKeys :: (forall m. CommandMonad m => m Char) -> Input IO Char +debugTerminalKeys eval = runIdT eval diff --git a/testsuite/tests/simplCore/should_compile/T22715_2a.hs b/testsuite/tests/simplCore/should_compile/T22715_2a.hs new file mode 100644 index 0000000000..d53cccd7aa --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T22715_2a.hs @@ -0,0 +1,29 @@ +{-# OPTIONS_GHC -Wno-missing-methods #-} + +module T22715_2a where + +newtype IdentityT m a = IdentityT (m a) deriving Functor +newtype IdT m a = IdT {runIdT :: m a} deriving Functor + +class Functor m => SillyA m where + unused :: m a -> m a + +class SillyA m => SillyB m where + unused2 :: m a -> m a + +instance SillyA m => SillyA (IdentityT m) where +instance SillyB m => SillyB (IdentityT m) where + +instance SillyA m => SillyA (IdT m) where +instance SillyB m => SillyB (IdT m) where + +instance SillyA IO where +instance SillyB IO where + +class Functor m => Special m +instance Functor m => Special (IdT m) + +type Input m = IdentityT (IdentityT m) + +class (Special m, SillyB m) => CommandMonad m +instance SillyB m => CommandMonad (IdT (Input m)) diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 068b830a51..a07aba3940 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -469,4 +469,4 @@ test('T22662', normal, compile, ['']) test('T22725', normal, compile, ['-O']) test('T22502', normal, compile, ['-O']) test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile, ['-O -ddump-simpl -dsuppress-uniques -dsuppress-all']) - +test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively']) |