diff options
| author | Sebastian Graf <sebastian.graf@kit.edu> | 2022-04-07 17:21:08 +0200 |
|---|---|---|
| committer | Sebastian Graf <sebastian.graf@kit.edu> | 2022-04-12 17:54:57 +0200 |
| commit | 4d2ee313f23a4454d12c9f94ff132f078dd64d31 (patch) | |
| tree | e7bd7b66f35660864f19feb998ab1d9ca96665fa | |
| parent | 0090ad7b8b436961fe1e225aae214d0ea1381c07 (diff) | |
| download | haskell-4d2ee313f23a4454d12c9f94ff132f078dd64d31.tar.gz | |
Specialising through specialised method calls (#19644)
In #19644, we discovered that the ClassOp/DFun rules from
Note [ClassOp/DFun selection] inhibit transitive specialisation in a scenario
like
```
class C a where m :: Show b => a -> b -> ...; n :: ...
instance C Int where m = ... -- $cm :: Show b => Int -> b -> ...
f :: forall a b. (C a, Show b) => ...
f $dC $dShow = ... m @a $dC @b $dShow ...
main = ... f @Int @Bool ...
```
After we specialise `f` for `Int`, we'll see `m @a $dC @b $dShow` in the body of
`$sf`. But before this patch, Specialise doesn't apply the ClassOp/DFun rule to
rewrite to a call of the instance method for `C Int`, e.g., `$cm @Bool $dShow`.
As a result, Specialise couldn't further specialise `$cm` for `Bool`.
There's a better example in `Note [Specialisation modulo dictionary selectors]`.
This patch enables proper Specialisation, as follows:
1. In the App case of `specExpr`, try to apply the CalssOp/DictSel rule on the
head of the application
2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and
`$dShow` in `bindAuxiliaryDict`
NB: Without (2), (1) would be pointless, because `lookupRule` wouldn't be able
to look into the RHS of `$dC` to see the DFun.
(2) triggered #21332, because the Specialiser floats around dictionaries without
accounting for them in the `SpecEnv`'s `InScopeSet`, triggering a panic when
rewriting dictionary unfoldings.
Fixes #19644 and #21332.
| -rw-r--r-- | compiler/GHC/Core/Opt/Arity.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/Opt/Specialise.hs | 234 | ||||
| -rw-r--r-- | compiler/GHC/Core/Rules.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Core/SimpleOpt.hs | 2 | ||||
| -rw-r--r-- | compiler/GHC/Core/Subst.hs | 19 | ||||
| -rw-r--r-- | compiler/GHC/Plugins.hs | 2 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/T4007.stdout | 1 | ||||
| -rw-r--r-- | testsuite/tests/perf/compiler/all.T | 1 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/Makefile | 5 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T17966.stderr | 310 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T19644.hs | 20 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T19644.stderr | 246 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T6056.stderr | 1 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/T7785.stderr | 410 | ||||
| -rw-r--r-- | testsuite/tests/simplCore/should_compile/all.T | 12 |
15 files changed, 1184 insertions, 90 deletions
diff --git a/compiler/GHC/Core/Opt/Arity.hs b/compiler/GHC/Core/Opt/Arity.hs index 6c0729ec5b..c78285c6f9 100644 --- a/compiler/GHC/Core/Opt/Arity.hs +++ b/compiler/GHC/Core/Opt/Arity.hs @@ -45,7 +45,7 @@ import GHC.Core.Multiplicity -- We have two sorts of substitution: -- GHC.Core.Subst.Subst, and GHC.Core.TyCo.TCvSubst -- Both have substTy, substCo Hence need for qualification -import GHC.Core.Subst as Core +import GHC.Core.Subst as Core hiding ( extendInScopeSet ) import GHC.Core.Type as Type import GHC.Core.Coercion as Type diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs index d9cc090d3d..6801e3e0a8 100644 --- a/compiler/GHC/Core/Opt/Specialise.hs +++ b/compiler/GHC/Core/Opt/Specialise.hs @@ -67,6 +67,7 @@ import GHC.Utils.Trace import GHC.Unit.Module( Module ) import GHC.Unit.Module.ModGuts import GHC.Unit.External +import GHC.Core.Unfold {- ************************************************************************ @@ -614,7 +615,8 @@ specProgram guts@(ModGuts { mg_module = this_mod go [] = return ([], emptyUDs) go (bind:binds) = do (binds', uds) <- go binds - (bind', uds') <- specBind top_env bind uds + let env = bringFloatedDictsIntoScope top_env uds + (bind', uds') <- specBind env bind uds return (bind' ++ binds', uds') -- Specialise the bindings of this module @@ -1116,16 +1118,12 @@ specExpr env (Tick tickish body) ---------------- Applications might generate a call instance -------------------- specExpr env expr@(App {}) - = go expr [] - where - go (App fun arg) args = do (arg', uds_arg) <- specExpr env arg - (fun', uds_app) <- go fun (arg':args) - return (App fun' arg', uds_arg `plusUDs` uds_app) - - go (Var f) args = case specVar env f of - Var f' -> return (Var f', mkCallUDs env f' args) - e' -> return (e', emptyUDs) -- I don't expect this! - go other _ = specExpr env other + = do { let (fun_in, args_in) = collectArgs expr + ; (args_out, uds_args) <- mapAndCombineSM (specExpr env) args_in + ; let (fun_in', args_out') = rewriteClassOps env fun_in args_out + ; (fun_out', uds_fun) <- specExpr env fun_in' + ; let uds_call = mkCallUDs env fun_out' args_out' + ; return (fun_out' `mkApps` args_out', uds_fun `plusUDs` uds_call `plusUDs` uds_args) } ---------------- Lambda/case require dumping of usage details -------------------- specExpr env e@(Lam {}) @@ -1152,10 +1150,23 @@ specExpr env (Let bind body) ; (body', body_uds) <- specExpr body_env body -- Deal with the bindings - ; (binds', uds) <- specBind rhs_env bind' body_uds - - -- All done - ; return (foldr Let body' binds', uds) } + ; let rhs_env' = bringFloatedDictsIntoScope rhs_env body_uds + ; (binds', uds) <- specBind rhs_env' bind' body_uds + + -- All done + ; return (foldr Let body' binds', uds) } + +-- See Note [Specialisation modulo dictionary selectors] +-- and Note [ClassOp/DFun selection] +rewriteClassOps :: SpecEnv -> InExpr -> [OutExpr] -> (InExpr, [OutExpr]) +rewriteClassOps env (Var f) args + | isClassOpId f -- If we see `op_sel $fCInt`, we rewrite to `$copInt` + , Just (rule, expr) <- specLookupRule env f args (idCoreRules f) + , let rest_args = drop (ruleArity rule) args -- See Note [Extra args in the target] + -- , pprTrace "class op rewritten" (ppr f <+> ppr args $$ ppr expr <+> ppr rest_args) True + , (fun, args) <- collectArgs expr + = rewriteClassOps env fun (args++rest_args) +rewriteClassOps _ fun args = (fun, args) -------------- specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails) @@ -1214,7 +1225,7 @@ specCase env scrut' case_bndr [Alt con args rhs] | (sc_arg_flt, sc_rhs) <- sc_args_flt `zip` sc_rhss ] flt_binds = scrut_bind : sc_binds (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds - all_uds = flt_binds `addDictBinds` free_uds + all_uds = flt_binds `consDictBinds` free_uds alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs') ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) } where @@ -1290,6 +1301,14 @@ to substitute sc -> sc_flt in the RHS ************************************************************************ -} +bringFloatedDictsIntoScope :: SpecEnv -> UsageDetails -> SpecEnv +bringFloatedDictsIntoScope env uds = + -- pprTrace "brought into scope" (ppr dx_bndrs) $ + env{se_subst=subst'} + where + dx_bndrs = ud_bs_of_binds uds + subst' = se_subst env `Core.extendInScopeSet` dx_bndrs + specBind :: SpecEnv -- Use this for RHSs -> CoreBind -- Binders are already cloned by cloneBindSM, -- but RHSs are un-processed @@ -1302,12 +1321,12 @@ specBind :: SpecEnv -- Use this for RHSs specBind rhs_env (NonRec fn rhs) body_uds = do { (rhs', rhs_uds) <- specExpr rhs_env rhs - ; let zapped_fn = zapIdDemandInfo fn + ; let zapped_fn = zapIdDemandInfo fn -- We zap the demand info because the binding may float, -- which would invaidate the demand info (see #17810 for example). -- Destroying demand info is not terrible; specialisation is -- always followed soon by demand analysis. - ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs + ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs ; let pairs = spec_defns ++ [(fn', rhs')] -- fn' mentions the spec_defns in its rules, @@ -1461,7 +1480,6 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs is_local = isLocalId fn is_dfun = isDFunId fn dflags = se_dflags env - ropts = initRuleOpts dflags this_mod = se_module env -- Figure out whether the function has an INLINE pragma -- See Note [Inline specialisations] @@ -1469,13 +1487,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs -- See Note [Account for casts in binding] - in_scope = Core.substInScope (se_subst env) - - already_covered :: RuleOpts -> [CoreRule] -> [CoreExpr] -> Bool - already_covered ropts new_rules args -- Note [Specialisations already covered] - = isJust (lookupRule ropts (in_scope, realIdUnfolding) - (const True) fn args - (new_rules ++ existing_rules)) + already_covered :: [CoreRule] -> [CoreExpr] -> Bool + already_covered new_rules args -- Note [Specialisations already covered] + = isJust (specLookupRule env fn args (new_rules ++ existing_rules)) -- NB: we look both in the new_rules (generated by this invocation -- of specCalls), and in existing_rules (passed in to specCalls) @@ -1493,7 +1507,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , rule_bndrs, rule_lhs_args , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args --- ; pprTrace "spec_call" (vcat [ text "call info: " <+> ppr _ci +-- ; 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 @@ -1505,7 +1520,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs -- return () ; if not useful -- No useful specialisation - || already_covered ropts rules_acc rule_lhs_args + || already_covered rules_acc rule_lhs_args then return spec_acc else do { -- Run the specialiser on the specialised RHS @@ -1615,6 +1630,16 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs , spec_uds `plusUDs` uds_acc ) } } +-- Convenience function for invoking lookupRule from Specialise +specLookupRule :: SpecEnv -> Id -> [CoreExpr] -> [CoreRule] -> Maybe (CoreRule, CoreExpr) +specLookupRule env fn args rules + = lookupRule ropts (in_scope, realIdUnfolding) (const True) fn args rules + where + dflags = se_dflags env + in_scope = Core.substInScope (se_subst env) + ropts = initRuleOpts dflags + + {- Note [Specialising DFuns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ DFuns have a special sort of unfolding (DFunUnfolding), and these are @@ -1771,6 +1796,55 @@ Wrinkles The right thing to do is to produce a LitRubbish; it should rapidly disappear. Rather like GHC.Core.Opt.WorkWrap.Utils.mk_absent_let. +Note [Specialisation modulo dictionary selectors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In #19644, we discovered that the ClassOp/DFun rules from +Note [ClassOp/DFun selection] inhibit transitive specialisation. +Example, inspired by T17966: + + class C a where + m :: Show b => a -> b -> String + dummy :: a -> () -- Force a datatype dictionary representation + + instance C Int where + m a b = show a ++ show b + dummy _ = () + + f :: (C a, Show b) => a -> b -> String + f a b = m a b ++ "!" + {-# INLINABLE[0] f #-} + + main = putStrLn (f (42::Int) (True::Bool)) + +Here, we specialise `f` at `Int` and `Bool`, giving + + $dC = $fCInt + $dShow = GHC.Show.$fShowBool + $sf (a::Int) (b::Bool) = + ... (m @Int $dC @Bool $dShow a b) ... + +Here `m` is just a DictSel, so there is (apparently) nothing to specialise! +However, the next Simplifier run will expose the rewritten instance method: + + ... $fCInt_$cm @Bool $fShowBool a b ... + +where $fCInt_$cm is the instance method for `m` in `instance C Int`: + + $fCInt_$cm :: forall b. Show b => Int -> b -> String + $fCInt_$cm b d x y = show @Int $dShowInt x ++ show @b d y + +We want to specialise this! How? By doing the the method-selection rewrite in +the Specialiser. Hence + +1. In the App case of 'specExpr', try to apply the ClassOp/DFun rule on the + head of the application, repeatedly, via 'rewriteClassOps'. +2. Attach an unfolding to freshly-bound dictionary ids such as `$dC` and + `$dShow` in `bindAuxiliaryDict`, so that we can exploit the unfolding + in 'rewriteClassOps' to do the ClassOp/DFun rewrite. + +NB: Without (2), (1) would be pointless, because 'lookupRule' wouldn't be able +to look into the RHS of `$dC` to see the DFun. + Note [Zap occ info in rule binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we generate a specialisation RULE, we need to drop occurrence @@ -2403,15 +2477,21 @@ bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting }) `Core.extendInScope` dict_id -- See Note [Keep the old dictionaries interesting] , se_interesting = interesting `extendVarSet` dict_id } - in (env', Nothing, dict_expr) + in -- pprTrace "bindAuxiliaryDict:trivial" (ppr orig_dict_id <+> ppr dict_id) $ + (env', Nothing, dict_expr) | otherwise -- Non-trivial dictionary arg; make an auxiliary binding - = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr) - env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id) - `Core.extendInScope` fresh_dict_id + = let dict_unf = mkSimpleUnfolding defaultUnfoldingOpts dict_expr + fresh_dict_id' = fresh_dict_id `setIdUnfolding` dict_unf + -- See Note [Specialisation modulo dictionary selectors] for the unfolding + dict_bind = mkDB (NonRec fresh_dict_id' dict_expr) + env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id') + `Core.extendInScope` fresh_dict_id' + `Core.extendInScopeList` exprFreeVarsList dict_expr -- See Note [Make the new dictionaries interesting] - , se_interesting = interesting `extendVarSet` fresh_dict_id } - in (env', Just dict_bind, Var fresh_dict_id) + , se_interesting = interesting `extendVarSet` fresh_dict_id' } + in -- pprTrace "bindAuxiliaryDict:non-trivial" (ppr orig_dict_id <+> ppr fresh_dict_id' $$ ppr dict_expr $$ ppr (exprFreeVarsList dict_expr)) $ + (env', Just dict_bind, Var fresh_dict_id') {- Note [Make the new dictionaries interesting] @@ -2480,6 +2560,12 @@ data UsageDetails -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1 -- (Remember, Bags preserve order in GHC.) + ud_bs_of_binds :: !IdSet, + -- ^ The binders of 'ud_binds'. + -- Caches a superset of the expression + -- `mkVarSet (bindersOfDictBinds ud_binds))` + -- for later addition to an InScopeSet + ud_calls :: !CallDetails -- INVARIANT: suppose bs = bindersOf ud_binds @@ -2491,6 +2577,12 @@ data UsageDetails -- variables (both type variables and dictionaries) data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet } +bindersOfDictBind :: DictBind -> [Id] +bindersOfDictBind = bindersOf . db_bind + +bindersOfDictBinds :: Foldable f => f DictBind -> [Id] +bindersOfDictBinds = bindersOfBinds . foldr ((:) . db_bind) [] + {- Note [Floated dictionary bindings] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We float out dictionary bindings for the reasons described under @@ -2517,6 +2609,10 @@ successfully specialise 'f'. So the DictBinds in (ud_binds :: Bag DictBind) may contain non-dictionary bindings too. +It's important to add the dictionary binders that are currently in-float to the +InScopeSet of the SpecEnv before calling 'specBind'. That's what we do when we +call 'bringFloatedDictsIntoScope'. + Note [Specialising polymorphic dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -2584,7 +2680,9 @@ instance Outputable UsageDetails where text "calls" <+> equals <+> ppr calls])) emptyUDs :: UsageDetails -emptyUDs = MkUD { ud_binds = emptyBag, ud_calls = emptyDVarEnv } +emptyUDs = MkUD { ud_binds = emptyBag + , ud_bs_of_binds = emptyVarSet + , ud_calls = emptyDVarEnv } ------------------------------------------------------------ type CallDetails = DIdEnv CallInfoSet @@ -2653,7 +2751,7 @@ getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedB ------------------------------------------------------------ singleCall :: Id -> [SpecArg] -> UsageDetails singleCall id args - = MkUD {ud_binds = emptyBag, + = MkUD {ud_binds = emptyBag, ud_bs_of_binds = emptyVarSet, ud_calls = unitDVarEnv id $ CIS id $ unitBag (CI { ci_key = args -- used to be tys , ci_fvs = call_fvs }) } @@ -2669,13 +2767,15 @@ singleCall id args -- -- We don't include the 'id' itself. -mkCallUDs, mkCallUDs' :: SpecEnv -> Id -> [CoreExpr] -> UsageDetails -mkCallUDs env f args - = -- pprTrace "mkCallUDs" (vcat [ ppr f, ppr args, ppr res ]) - res - where - res = mkCallUDs' env f args +mkCallUDs :: SpecEnv -> OutExpr -> [OutExpr] -> UsageDetails +mkCallUDs env fun args + | Var f <- fun + = -- pprTraceWith "mkCallUDs" (\res -> vcat [ ppr f, ppr args, ppr res ]) $ + mkCallUDs' env f args + | otherwise + = emptyUDs +mkCallUDs' :: SpecEnv -> Id -> [OutExpr] -> UsageDetails mkCallUDs' env f args | wantCallsFor env f -- We want it, and... , not (null ci_key) -- this call site has a useful specialisation @@ -2699,7 +2799,7 @@ mkCallUDs' env f args -- which broadens its applicability, since rules only -- fire when saturated - mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg + mk_spec_arg :: OutExpr -> TyCoBinder -> SpecArg mk_spec_arg arg (Named bndr) | binderVar bndr `elemVarSet` constrained_tyvars = case arg of @@ -2797,10 +2897,11 @@ interestingDict env (Cast e _) = interestingDict env e interestingDict _ _ = True plusUDs :: UsageDetails -> UsageDetails -> UsageDetails -plusUDs (MkUD {ud_binds = db1, ud_calls = calls1}) - (MkUD {ud_binds = db2, ud_calls = calls2}) - = MkUD { ud_binds = db1 `unionBags` db2 - , ud_calls = calls1 `unionCalls` calls2 } +plusUDs (MkUD {ud_binds = db1, ud_bs_of_binds = bs1, ud_calls = calls1}) + (MkUD {ud_binds = db2, ud_bs_of_binds = bs2, ud_calls = calls2}) + = MkUD { ud_binds = db1 `unionBags` db2 + , ud_bs_of_binds = bs1 `unionVarSet` bs2 + , ud_calls = calls1 `unionCalls` calls2 } ----------------------------- _dictBindBndrs :: Bag DictBind -> [Id] @@ -2851,19 +2952,26 @@ recWithDumpedDicts pairs dbs where fvs' = fvs_acc `unionVarSet` fvs +snocDictBind :: UsageDetails -> DictBind -> UsageDetails +snocDictBind uds@MkUD{ud_binds=dbs,ud_bs_of_binds=bs} db + = uds { ud_binds = dbs `snocBag` db + , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBind db } + snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails -- Add ud_binds to the tail end of the bindings in uds -snocDictBinds uds dbs - = uds { ud_binds = ud_binds uds `unionBags` listToBag dbs } +snocDictBinds uds@MkUD{ud_binds=binds,ud_bs_of_binds=bs} dbs + = uds { ud_binds = binds `unionBags` listToBag dbs + , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBinds dbs } consDictBind :: DictBind -> UsageDetails -> UsageDetails -consDictBind bind uds = uds { ud_binds = bind `consBag` ud_binds uds } +consDictBind db uds@MkUD{ud_binds=binds,ud_bs_of_binds=bs} + = uds { ud_binds = db `consBag` binds + , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBind db } -addDictBinds :: [DictBind] -> UsageDetails -> UsageDetails -addDictBinds binds uds = uds { ud_binds = listToBag binds `unionBags` ud_binds uds } - -snocDictBind :: UsageDetails -> DictBind -> UsageDetails -snocDictBind uds bind = uds { ud_binds = ud_binds uds `snocBag` bind } +consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails +consDictBinds dbs uds@MkUD{ud_binds=binds,ud_bs_of_binds=bs} + = uds { ud_binds = listToBag dbs `unionBags` binds + , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBinds dbs } wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind] wrapDictBinds dbs binds @@ -2880,14 +2988,15 @@ wrapDictBindsE dbs expr ---------------------- dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind) -- Used at a lambda or case binder; just dump anything mentioning the binder -dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) +dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_bs_of_binds = bs, ud_calls = orig_calls }) | null bndrs = (uds, emptyBag) -- Common in case alternatives | otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ (free_uds, dump_dbs) where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + free_uds = uds { ud_binds = free_dbs, ud_bs_of_binds = free_bs, ud_calls = free_calls } bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_bs = bs `minusVarSet` dump_set free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be -- no calls for any of the dicts in dump_dbs @@ -2898,28 +3007,27 @@ dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool) -- directly or indirectly, by any of the ud_calls; in that case we want to -- float the binding itself; -- See Note [Floated dictionary bindings] -dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) +dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_bs_of_binds = bs, ud_calls = orig_calls }) = -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $ (free_uds, dump_dbs, float_all) where - free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls } + free_uds = MkUD { ud_binds = free_dbs, ud_bs_of_binds = free_bs, ud_calls = free_calls } bndr_set = mkVarSet bndrs (free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set + free_bs = bs `minusVarSet` dump_set free_calls = deleteCallsFor bndrs orig_calls float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls callsForMe :: Id -> UsageDetails -> (UsageDetails, [CallInfo]) -callsForMe fn (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }) +callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls } = -- pprTrace ("callsForMe") -- (vcat [ppr fn, -- text "Orig dbs =" <+> ppr (_dictBindBndrs orig_dbs), -- text "Orig calls =" <+> ppr orig_calls, - -- text "Dep set =" <+> ppr dep_set, -- text "Calls for me =" <+> ppr calls_for_me]) $ (uds_without_me, calls_for_me) where - uds_without_me = MkUD { ud_binds = orig_dbs - , ud_calls = delDVarEnv orig_calls fn } + uds_without_me = uds { ud_calls = delDVarEnv orig_calls fn } calls_for_me = case lookupDVarEnv orig_calls fn of Nothing -> [] Just cis -> filterCalls cis orig_dbs diff --git a/compiler/GHC/Core/Rules.hs b/compiler/GHC/Core/Rules.hs index 1db2645f51..a8c9cbef5a 100644 --- a/compiler/GHC/Core/Rules.hs +++ b/compiler/GHC/Core/Rules.hs @@ -522,11 +522,14 @@ matchRule :: RuleOpts -> InScopeEnv -> (Activation -> Bool) -- [f,map g x] -- tpl_args -- map (f.g) x) -- rhs -- --- Then the call: matchRule the_rule [e1,map e2 e3] +-- Then the expression +-- map e1 (map e2 e3) e4 +-- results in a call to +-- matchRule the_rule [e1,map e2 e3,e4] -- = Just ("map/map", (\f,g,x -> rhs) e1 e2 e3) -- --- Any 'surplus' arguments in the input are simply put on the end --- of the output. +-- NB: The 'surplus' argument e4 in the input is simply dropped. +-- See Note [Extra args in the target] matchRule opts rule_env _is_active fn args _rough_args (BuiltinRule { ru_try = match_fn }) diff --git a/compiler/GHC/Core/SimpleOpt.hs b/compiler/GHC/Core/SimpleOpt.hs index 925eaf5841..360c868738 100644 --- a/compiler/GHC/Core/SimpleOpt.hs +++ b/compiler/GHC/Core/SimpleOpt.hs @@ -22,7 +22,7 @@ import GHC.Prelude import GHC.Core import GHC.Core.Opt.Arity -import GHC.Core.Subst +import GHC.Core.Subst hiding ( extendInScopeSet ) import GHC.Core.Utils import GHC.Core.FVs import GHC.Core.Unfold diff --git a/compiler/GHC/Core/Subst.hs b/compiler/GHC/Core/Subst.hs index 172e8ac67d..2c470c5dcb 100644 --- a/compiler/GHC/Core/Subst.hs +++ b/compiler/GHC/Core/Subst.hs @@ -24,7 +24,7 @@ module GHC.Core.Subst ( emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList, extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, - extendInScope, extendInScopeList, extendInScopeIds, + extendInScope, extendInScopeList, extendInScopeIds, GHC.Core.Subst.extendInScopeSet, isInScope, setInScope, getTCvSubst, extendTvSubst, extendCvSubst, delBndr, delBndrs, @@ -50,13 +50,14 @@ import GHC.Core.Type hiding import GHC.Core.Coercion hiding ( substCo, substCoVarBndr ) import GHC.Types.Var.Set -import GHC.Types.Var.Env +import GHC.Types.Var.Env as InScopeSet import GHC.Types.Id import GHC.Types.Name ( Name ) import GHC.Types.Var import GHC.Types.Tickish import GHC.Types.Id.Info import GHC.Types.Unique.Supply +import GHC.Types.Unique.Set import GHC.Builtin.Names import GHC.Data.Maybe @@ -288,7 +289,7 @@ isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -- and remove any existing substitutions for it extendInScope :: Subst -> Var -> Subst extendInScope (Subst in_scope ids tvs cvs) v - = Subst (in_scope `extendInScopeSet` v) + = Subst (in_scope `InScopeSet.extendInScopeSet` v) (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) -- | Add the 'Var's to the in-scope set: see also 'extendInScope' @@ -304,6 +305,14 @@ extendInScopeIds (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) (ids `delVarEnvList` vs) tvs cvs +-- | Add the 'Var's to the in-scope set: see also 'extendInScope' +extendInScopeSet :: Subst -> VarSet -> Subst +extendInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) + (ids `minus` vs) (tvs `minus` vs) (cvs `minus` vs) + where + minus env set = minusVarEnv env (getUniqSet set) + setInScope :: Subst -> InScopeSet -> Subst setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs @@ -462,7 +471,7 @@ substIdBndr :: SDoc substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ - (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) + (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_env tvs cvs, new_id) where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 @@ -532,7 +541,7 @@ clone_id :: Subst -- Substitution for the IdInfo -> (Subst, Id) -- Transformed pair clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq) - = (Subst (in_scope `extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) + = (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 diff --git a/compiler/GHC/Plugins.hs b/compiler/GHC/Plugins.hs index 2de8d8d370..e79362b9d1 100644 --- a/compiler/GHC/Plugins.hs +++ b/compiler/GHC/Plugins.hs @@ -88,7 +88,7 @@ import GHC.Core.DataCon import GHC.Core.Utils import GHC.Core.Make import GHC.Core.FVs -import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst ) +import GHC.Core.Subst hiding( substTyVarBndr, substCoVarBndr, extendCvSubst, extendInScopeSet ) -- These names are also exported by Type import GHC.Core.Rules diff --git a/testsuite/tests/perf/compiler/T4007.stdout b/testsuite/tests/perf/compiler/T4007.stdout index c83de9cfd9..fc69f2c1c3 100644 --- a/testsuite/tests/perf/compiler/T4007.stdout +++ b/testsuite/tests/perf/compiler/T4007.stdout @@ -3,7 +3,6 @@ Rule fired: Class op return (BUILTIN) Rule fired: unpack (GHC.Base) Rule fired: fold/build (GHC.Base) Rule fired: Class op >> (BUILTIN) -Rule fired: Class op >> (BUILTIN) Rule fired: SPEC/T4007 sequence__c @IO _ _ (T4007) Rule fired: <# (BUILTIN) Rule fired: tagToEnum# (BUILTIN) diff --git a/testsuite/tests/perf/compiler/all.T b/testsuite/tests/perf/compiler/all.T index 5cbe3b6e51..17bb717ee9 100644 --- a/testsuite/tests/perf/compiler/all.T +++ b/testsuite/tests/perf/compiler/all.T @@ -54,6 +54,7 @@ test('T3064', compile, ['']) +# The foldr/build rule is the important one test('T4007', normal, makefile_test, ['T4007']) test('T5030', diff --git a/testsuite/tests/simplCore/should_compile/Makefile b/testsuite/tests/simplCore/should_compile/Makefile index b5041800ed..02358e1746 100644 --- a/testsuite/tests/simplCore/should_compile/Makefile +++ b/testsuite/tests/simplCore/should_compile/Makefile @@ -13,11 +13,6 @@ T18815: $(RM) -f T18815.o T18815.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-simpl T18815.hs 2> /dev/null | grep 'join ' -T17966: - $(RM) -f T17966.o T17966.hi - - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-spec T17966.hs 2> /dev/null | grep 'SPEC' - # Expecting a SPEC rule for $cm - T17409: $(RM) -f T17409.o T17409.hi - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -dverbose-core2core -dsuppress-uniques T17409.hs 2> /dev/null | grep '\<id\>' diff --git a/testsuite/tests/simplCore/should_compile/T17966.stderr b/testsuite/tests/simplCore/should_compile/T17966.stderr new file mode 100644 index 0000000000..24e09d538f --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T17966.stderr @@ -0,0 +1,310 @@ + +==================== Specialise ==================== +Result size of Specialise + = {terms: 166, types: 158, coercions: 24, joins: 0/0} + +-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} +$dShow_sRN :: Show (Maybe Integer) +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=True, + WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$dShow_sRN = GHC.Show.$fShowMaybe @Integer GHC.Show.$fShowInteger + +Rec { +-- RHS size: {terms: 2, types: 1, coercions: 4, joins: 0/0} +$dC_sRM :: C Bool () +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 60}] +$dC_sRM + = ($cm_aHo @() GHC.Show.$fShow()) + `cast` (Sym (T17966.N:C[0] <Bool>_N <()>_N) + :: (forall c. Show c => Bool -> () -> c -> String) ~R# C Bool ()) + +-- RHS size: {terms: 30, types: 24, coercions: 0, joins: 0/0} +$s$cm_sRQ [InlPrag=[0]] + :: forall {c}. Show c => Bool -> () -> c -> [Char] +[LclId, Arity=4] +$s$cm_sRQ + = \ (@c_aHr) + ($dShow_aHs :: Show c_aHr) + (a_aBf :: Bool) + (b_aBg :: ()) + (c_aBh :: c_aHr) -> + GHC.Base.augment + @Char + (\ (@b_aQg) + (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg) + (n_aQi [OS=OneShot] :: b_aQg) -> + GHC.Base.foldr + @Char + @b_aQg + c_aQh + n_aQi + (case a_aBf of { + False -> GHC.Show.$fShowBool5; + True -> GHC.Show.$fShowBool4 + })) + (GHC.Base.augment + @Char + (\ (@b_aQg) + (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg) + (n_aQi [OS=OneShot] :: b_aQg) -> + GHC.Base.foldr + @Char @b_aQg c_aQh n_aQi (GHC.Show.$fShow()_$cshow b_aBg)) + (show @c_aHr $dShow_aHs c_aBh)) + +-- RHS size: {terms: 33, types: 28, coercions: 0, joins: 0/0} +$cm_aHo [InlPrag=INLINABLE[0]] + :: forall b c. (Show b, Show c) => Bool -> b -> c -> String +[LclId, + Arity=5, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=IF_ARGS [30 30 30 0 0] 140 0 + Tmpl= \ (@b_aHl) + ($dShow_aHm [Occ=Once1] :: Show b_aHl) + (@c_aHr) + ($dShow_aHs [Occ=Once1] :: Show c_aHr) + (a_aBf [Occ=Once1!] :: Bool) + (b_aBg [Occ=Once1] :: b_aHl) + (c_aBh [Occ=Once1] :: c_aHr) -> + ++ + @Char + (case a_aBf of { + False -> GHC.Show.$fShowBool5; + True -> GHC.Show.$fShowBool4 + }) + (++ + @Char + (show @b_aHl $dShow_aHm b_aBg) + (show @c_aHr $dShow_aHs c_aBh))}, + RULES: "SPEC $cm @()" [0] + forall ($dShow_sRP :: Show ()). $cm_aHo @() $dShow_sRP = $s$cm_sRQ] +$cm_aHo + = \ (@b_aHl) + ($dShow_aHm :: Show b_aHl) + (@c_aHr) + ($dShow_aHs :: Show c_aHr) + (a_aBf :: Bool) + (b_aBg :: b_aHl) + (c_aBh :: c_aHr) -> + GHC.Base.augment + @Char + (\ (@b_aQg) + (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg) + (n_aQi [OS=OneShot] :: b_aQg) -> + GHC.Base.foldr + @Char + @b_aQg + c_aQh + n_aQi + (case a_aBf of { + False -> GHC.Show.$fShowBool5; + True -> GHC.Show.$fShowBool4 + })) + (GHC.Base.augment + @Char + (\ (@b_aQg) + (c_aQh [OS=OneShot] :: Char -> b_aQg -> b_aQg) + (n_aQi [OS=OneShot] :: b_aQg) -> + GHC.Base.foldr + @Char @b_aQg c_aQh n_aQi (show @b_aHl $dShow_aHm b_aBg)) + (show @c_aHr $dShow_aHs c_aBh)) +end Rec } + +-- RHS size: {terms: 1, types: 0, coercions: 10, joins: 0/0} +T17966.$fCBoolb [InlPrag=INLINE (sat-args=0)] + :: forall b. Show b => C Bool b +[LclIdX[DFunId(nt)], + Arity=5, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=False,boring_ok=True) + Tmpl= $cm_aHo + `cast` (forall (b :: <*>_N). + <Show b>_R %<'Many>_N ->_R Sym (T17966.N:C[0] <Bool>_N <b>_N) + :: (forall {b} c. (Show b, Show c) => Bool -> b -> c -> String) + ~R# (forall {b}. Show b => C Bool b))}] +T17966.$fCBoolb + = $cm_aHo + `cast` (forall (b :: <*>_N). + <Show b>_R %<'Many>_N ->_R Sym (T17966.N:C[0] <Bool>_N <b>_N) + :: (forall {b} c. (Show b, Show c) => Bool -> b -> c -> String) + ~R# (forall {b}. Show b => C Bool b)) + +-- RHS size: {terms: 18, types: 15, coercions: 3, joins: 0/0} +$sf_sRO [InlPrag=[0]] :: Bool -> () -> Maybe Integer -> [Char] +[LclId, Arity=3] +$sf_sRO + = \ (a_aBl :: Bool) (b_aBm :: ()) (c_aBn :: Maybe Integer) -> + GHC.Base.build + @Char + (\ (@b_aQz) + (c_aQA [OS=OneShot] :: Char -> b_aQz -> b_aQz) + (n_aQB [OS=OneShot] :: b_aQz) -> + GHC.Base.foldr + @Char + @b_aQz + c_aQA + (GHC.CString.unpackFoldrCString# @b_aQz "!"# c_aQA n_aQB) + (($dC_sRM + `cast` (T17966.N:C[0] <Bool>_N <()>_N + :: C Bool () ~R# (forall c. Show c => Bool -> () -> c -> String))) + @(Maybe Integer) $dShow_sRN a_aBl b_aBm c_aBn)) + +-- RHS size: {terms: 23, types: 21, coercions: 3, joins: 0/0} +f [InlPrag=INLINABLE[0]] + :: forall a b c. (C a b, Show c) => a -> b -> c -> String +[LclIdX, + Arity=5, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [60 0 0 0 0] 120 0 + Tmpl= \ (@a_aFi) + (@b_aFj) + (@c_aFk) + ($dC_aFl [Occ=Once1] :: C a_aFi b_aFj) + ($dShow_aFm [Occ=Once1] :: Show c_aFk) + (a_aBl [Occ=Once1] :: a_aFi) + (b_aBm [Occ=Once1] :: b_aFj) + (c_aBn [Occ=Once1] :: c_aFk) -> + ++ + @Char + (($dC_aFl + `cast` (T17966.N:C[0] <a_aFi>_N <b_aFj>_N + :: C a_aFi b_aFj + ~R# (forall c. Show c => a_aFi -> b_aFj -> c -> String))) + @c_aFk $dShow_aFm a_aBl b_aBm c_aBn) + (GHC.CString.unpackCString# "!"#)}, + RULES: "SPEC f @Bool @() @(Maybe Integer)" [0] + forall ($dC_sRM :: C Bool ()) ($dShow_sRN :: Show (Maybe Integer)). + f @Bool @() @(Maybe Integer) $dC_sRM $dShow_sRN + = $sf_sRO] +f = \ (@a_aFi) + (@b_aFj) + (@c_aFk) + ($dC_aFl :: C a_aFi b_aFj) + ($dShow_aFm :: Show c_aFk) + (a_aBl :: a_aFi) + (b_aBm :: b_aFj) + (c_aBn :: c_aFk) -> + GHC.Base.build + @Char + (\ (@b_aQz) + (c_aQA [OS=OneShot] :: Char -> b_aQz -> b_aQz) + (n_aQB [OS=OneShot] :: b_aQz) -> + GHC.Base.foldr + @Char + @b_aQz + c_aQA + (GHC.CString.unpackFoldrCString# @b_aQz "!"# c_aQA n_aQB) + (($dC_aFl + `cast` (T17966.N:C[0] <a_aFi>_N <b_aFj>_N + :: C a_aFi b_aFj + ~R# (forall c. Show c => a_aFi -> b_aFj -> c -> String))) + @c_aFk $dShow_aFm a_aBl b_aBm c_aBn)) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sRG :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$trModule_sRG = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sRH :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$trModule_sRH = GHC.Types.TrNameS $trModule_sRG + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sRI :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +$trModule_sRI = "T17966"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sRJ :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$trModule_sRJ = GHC.Types.TrNameS $trModule_sRI + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T17966.$trModule :: GHC.Types.Module +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T17966.$trModule = GHC.Types.Module $trModule_sRH $trModule_sRJ + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep_aPr [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aPr + = GHC.Types.KindRepTyConApp + GHC.Types.$tcConstraint (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep_aPq [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aPq = GHC.Types.KindRepFun GHC.Types.krep$* $krep_aPr + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep_aPp [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aPp = GHC.Types.KindRepFun GHC.Types.krep$* $krep_aPq + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tcC_sRK :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$tcC_sRK = "C"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tcC_sRL :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$tcC_sRL = GHC.Types.TrNameS $tcC_sRK + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T17966.$tcC :: GHC.Types.TyCon +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T17966.$tcC + = GHC.Types.TyCon + 12503088876068780286##64 + 926716241154773768##64 + T17966.$trModule + $tcC_sRL + 0# + $krep_aPp + +-- RHS size: {terms: 10, types: 7, coercions: 4, joins: 0/0} +x :: String +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 120 0}] +x = f @Bool + @() + @(Maybe Integer) + (($cm_aHo @() GHC.Show.$fShow()) + `cast` (Sym (T17966.N:C[0] <Bool>_N <()>_N) + :: (forall c. Show c => Bool -> () -> c -> String) ~R# C Bool ())) + (GHC.Show.$fShowMaybe @Integer GHC.Show.$fShowInteger) + GHC.Types.True + GHC.Tuple.() + (GHC.Maybe.Just @Integer (GHC.Num.Integer.IS 42#)) + + + diff --git a/testsuite/tests/simplCore/should_compile/T19644.hs b/testsuite/tests/simplCore/should_compile/T19644.hs new file mode 100644 index 0000000000..01f9f54f5e --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19644.hs @@ -0,0 +1,20 @@ +-- {-# OPTIONS_GHC -Wincomplete-patterns -fforce-recomp #-} +-- {-# OPTIONS_GHC -O2 -fforce-recomp #-} +-- {-# LANGUAGE PatternSynonyms #-} +-- {-# LANGUAGE BangPatterns #-} +-- {-# LANGUAGE MagicHash, UnboxedTuples #-} +module T19644 where + +class C a where + m :: Show b => a -> b -> String + dummy :: a -> () -- Force a datatype dictionary representation + +instance C Int where + m a b = show a ++ show b + dummy _ = () + +f :: (C a, Show b) => a -> b -> String +f a b = m a b ++ "!" +{-# INLINABLE[0] f #-} + +main = putStrLn (f (42::Int) (True::Bool)) diff --git a/testsuite/tests/simplCore/should_compile/T19644.stderr b/testsuite/tests/simplCore/should_compile/T19644.stderr new file mode 100644 index 0000000000..e2c0e09e66 --- /dev/null +++ b/testsuite/tests/simplCore/should_compile/T19644.stderr @@ -0,0 +1,246 @@ + +==================== Specialise ==================== +Result size of Specialise + = {terms: 134, types: 114, coercions: 3, joins: 0/0} + +-- RHS size: {terms: 2, types: 1, coercions: 0, joins: 0/0} +$cdummy_aPi :: Int -> () +[LclId, + Arity=1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=1,unsat_ok=True,boring_ok=True)}] +$cdummy_aPi = \ _ [Occ=Dead] -> GHC.Tuple.() + +-- RHS size: {terms: 17, types: 13, coercions: 0, joins: 0/0} +$s$cm_sZO :: Int -> Bool -> [Char] +[LclId, Arity=2] +$s$cm_sZO + = \ (a_aBe :: Int) (b_aBf :: Bool) -> + GHC.Base.augment + @Char + (\ (@b_aQs) + (c_aQt [OS=OneShot] :: Char -> b_aQs -> b_aQs) + (n_aQu [OS=OneShot] :: b_aQs) -> + GHC.Base.foldr + @Char + @b_aQs + c_aQt + n_aQu + (case a_aBe of { GHC.Types.I# n_aQz -> + GHC.Show.itos n_aQz (GHC.Types.[] @Char) + })) + (GHC.Show.$fShowBool_$cshow b_aBf) + +-- RHS size: {terms: 20, types: 17, coercions: 0, joins: 0/0} +$cm_aP5 :: forall b. Show b => Int -> b -> String +[LclId, + Arity=3, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 20 0] 130 40}, + RULES: "SPEC $cm @Bool" + forall ($dShow_sZN :: Show Bool). + $cm_aP5 @Bool $dShow_sZN + = $s$cm_sZO] +$cm_aP5 + = \ (@b_aP8) + ($dShow_aP9 :: Show b_aP8) + (a_aBe :: Int) + (b_aBf :: b_aP8) -> + GHC.Base.augment + @Char + (\ (@b_aQs) + (c_aQt [OS=OneShot] :: Char -> b_aQs -> b_aQs) + (n_aQu [OS=OneShot] :: b_aQs) -> + GHC.Base.foldr + @Char + @b_aQs + c_aQt + n_aQu + (case a_aBe of { GHC.Types.I# n_aQz -> + GHC.Show.itos n_aQz (GHC.Types.[] @Char) + })) + (show @b_aP8 $dShow_aP9 b_aBf) + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +T19644.$fCInt [InlPrag=CONLIKE] :: C Int +[LclIdX[DFunId], + Unf=DFun: \ -> T19644.C:C TYPE: Int $cm_aP5 $cdummy_aPi] +T19644.$fCInt = T19644.C:C @Int $cm_aP5 $cdummy_aPi + +-- RHS size: {terms: 16, types: 12, coercions: 0, joins: 0/0} +$sf_sZM [InlPrag=[0]] :: Int -> Bool -> [Char] +[LclId, Arity=2] +$sf_sZM + = \ (a_aBi :: Int) (b_aBj :: Bool) -> + GHC.Base.build + @Char + (\ (@b_aQT) + (c_aQU [OS=OneShot] :: Char -> b_aQT -> b_aQT) + (n_aQV [OS=OneShot] :: b_aQT) -> + GHC.Base.foldr + @Char + @b_aQT + c_aQU + (GHC.CString.unpackFoldrCString# @b_aQT "!"# c_aQU n_aQV) + ($cm_aP5 @Bool GHC.Show.$fShowBool a_aBi b_aBj)) + +-- RHS size: {terms: 21, types: 19, coercions: 0, joins: 0/0} +f [InlPrag=INLINABLE[0]] + :: forall a b. (C a, Show b) => a -> b -> String +[LclIdX, + Arity=4, + Unf=Unf{Src=InlineStable, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 0] 120 0 + Tmpl= \ (@a_aOm) + (@b_aOn) + ($dC_aOo [Occ=Once1] :: C a_aOm) + ($dShow_aOp [Occ=Once1] :: Show b_aOn) + (a_aBi [Occ=Once1] :: a_aOm) + (b_aBj [Occ=Once1] :: b_aOn) -> + ++ + @Char + (m @a_aOm $dC_aOo @b_aOn $dShow_aOp a_aBi b_aBj) + (GHC.CString.unpackCString# "!"#)}, + RULES: "SPEC f @Int @Bool" [0] + forall ($dC_sZK :: C Int) ($dShow_sZL :: Show Bool). + f @Int @Bool $dC_sZK $dShow_sZL + = $sf_sZM] +f = \ (@a_aOm) + (@b_aOn) + ($dC_aOo :: C a_aOm) + ($dShow_aOp :: Show b_aOn) + (a_aBi :: a_aOm) + (b_aBj :: b_aOn) -> + GHC.Base.build + @Char + (\ (@b_aQT) + (c_aQU [OS=OneShot] :: Char -> b_aQT -> b_aQT) + (n_aQV [OS=OneShot] :: b_aQT) -> + GHC.Base.foldr + @Char + @b_aQT + c_aQU + (GHC.CString.unpackFoldrCString# @b_aQT "!"# c_aQU n_aQV) + (m @a_aOm $dC_aOo @b_aOn $dShow_aOp a_aBi b_aBj)) + +-- RHS size: {terms: 6, types: 2, coercions: 0, joins: 0/0} +main_sZC :: String +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False, + WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 60 0}] +main_sZC + = f @Int + @Bool + T19644.$fCInt + GHC.Show.$fShowBool + (GHC.Types.I# 42#) + GHC.Types.True + +-- RHS size: {terms: 4, types: 0, coercions: 0, joins: 0/0} +main_sZD + :: GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #) +[LclId, + Arity=1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 60}] +main_sZD + = GHC.IO.Handle.Text.hPutStr2 + GHC.IO.Handle.FD.stdout main_sZC GHC.Types.True + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +main :: IO () +[LclIdX, + Arity=1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}] +main + = main_sZD + `cast` (Sym (GHC.Types.N:IO[0] <()>_R) + :: (GHC.Prim.State# GHC.Prim.RealWorld + -> (# GHC.Prim.State# GHC.Prim.RealWorld, () #)) + ~R# IO ()) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sZE :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$trModule_sZE = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sZF :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$trModule_sZF = GHC.Types.TrNameS $trModule_sZE + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sZG :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 30 0}] +$trModule_sZG = "T19644"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sZH :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$trModule_sZH = GHC.Types.TrNameS $trModule_sZG + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +T19644.$trModule :: GHC.Types.Module +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19644.$trModule = GHC.Types.Module $trModule_sZF $trModule_sZH + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep_aPH [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aPH + = GHC.Types.KindRepTyConApp + GHC.Types.$tcConstraint (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep_aPG [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aPG = GHC.Types.KindRepFun GHC.Types.krep$* $krep_aPH + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tcC_sZI :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$tcC_sZI = "C"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tcC_sZJ :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$tcC_sZJ = GHC.Types.TrNameS $tcC_sZI + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +T19644.$tcC :: GHC.Types.TyCon +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +T19644.$tcC + = GHC.Types.TyCon + 3363473062474234294##64 + 5379444656532611026##64 + T19644.$trModule + $tcC_sZJ + 0# + $krep_aPG + + + diff --git a/testsuite/tests/simplCore/should_compile/T6056.stderr b/testsuite/tests/simplCore/should_compile/T6056.stderr index 7706318b4d..461ba97c70 100644 --- a/testsuite/tests/simplCore/should_compile/T6056.stderr +++ b/testsuite/tests/simplCore/should_compile/T6056.stderr @@ -1,5 +1,4 @@ Rule fired: SPEC/T6056 $wsmallerAndRest @Int (T6056) Rule fired: SPEC/T6056 $wsmallerAndRest @Int (T6056) -Rule fired: Class op < (BUILTIN) Rule fired: SPEC/T6056 $wsmallerAndRest @Int (T6056) Rule fired: SPEC/T6056 $wsmallerAndRest @Int (T6056) diff --git a/testsuite/tests/simplCore/should_compile/T7785.stderr b/testsuite/tests/simplCore/should_compile/T7785.stderr index f0187fe958..f2f819f89a 100644 --- a/testsuite/tests/simplCore/should_compile/T7785.stderr +++ b/testsuite/tests/simplCore/should_compile/T7785.stderr @@ -1,8 +1,408 @@ -==================== Tidy Core rules ==================== -"SPEC shared @[]" - forall ($dMyFunctor :: MyFunctor []) (irred :: Domain [] Int). - shared @[] $dMyFunctor irred - = bar_$sshared +==================== Specialise ==================== +Result size of Specialise + = {terms: 293, types: 99, coercions: 11, joins: 0/2} + +-- RHS size: {terms: 5, types: 10, coercions: 0, joins: 0/0} +$cmyfmap_aG0 + :: forall a b. (Domain [] a, Domain [] b) => (a -> b) -> [a] -> [b] +[LclId, + Arity=4, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, + Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=True)}] +$cmyfmap_aG0 + = \ (@a_aG3) (@b_aG4) _ [Occ=Dead] _ [Occ=Dead] -> + map @a_aG3 @b_aG4 + +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0} +Foo.$fMyFunctor[] [InlPrag=CONLIKE] :: MyFunctor [] +[LclIdX[DFunId(nt)], + Arity=4, + Unf=DFun: \ -> Foo.C:MyFunctor TYPE: [] $cmyfmap_aG0] +Foo.$fMyFunctor[] + = $cmyfmap_aG0 + `cast` (Sym (Foo.N:MyFunctor[0] <[]>_N) + :: (forall a b. + (Domain [] a, Domain [] b) => + (a -> b) -> [a] -> [b]) + ~R# MyFunctor []) + +-- RHS size: {terms: 114, types: 12, coercions: 0, joins: 0/1} +$sshared_sHu :: Domain [] Int => [Int] -> [Int] +[LclId, Arity=1] +$sshared_sHu + = \ (irred_azD :: Domain [] Int) -> + let { + f_sHt :: [Int] -> [Int] + [LclId] + f_sHt + = myfmap + @[] + Foo.$fMyFunctor[] + @Int + @Int + irred_azD + irred_azD + GHC.Num.$fNumInt_$cnegate } in + \ (x_X4N :: [Int]) -> + f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + (f_sHt + x_X4N)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +-- RHS size: {terms: 116, types: 16, coercions: 0, joins: 0/1} +shared + :: forall (f :: * -> *). + (MyFunctor f, Domain f Int) => + f Int -> f Int +[LclIdX, + Arity=2, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=NEVER}, + RULES: "SPEC shared @[]" + forall ($dMyFunctor_sHr :: MyFunctor []). + shared @[] $dMyFunctor_sHr + = $sshared_sHu] +shared + = \ (@(f_azB :: * -> *)) + ($dMyFunctor_azC :: MyFunctor f_azB) + (irred_azD :: Domain f_azB Int) -> + let { + f_sHq :: f_azB Int -> f_azB Int + [LclId] + f_sHq + = myfmap + @f_azB + $dMyFunctor_azC + @Int + @Int + irred_azD + irred_azD + GHC.Num.$fNumInt_$cnegate } in + \ (x_X4N :: f_azB Int) -> + f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + (f_sHq + x_X4N)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + +-- RHS size: {terms: 8, types: 4, coercions: 4, joins: 0/0} +foo :: [Int] -> [Int] +[LclIdX, + Arity=1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 60 0}] +foo + = \ (xs_axd :: [Int]) -> + shared + @[] + Foo.$fMyFunctor[] + (GHC.Classes.(%%) + `cast` (Sub (Sym (Foo.D:R:Domain[]a[0] <Int>_N)) + :: (() :: Constraint) ~R# Domain [] Int)) + (GHC.Types.: @Int (GHC.Types.I# 0#) xs_axd) + +-- RHS size: {terms: 8, types: 4, coercions: 4, joins: 0/0} +bar :: [Int] -> [Int] +[LclIdX, + Arity=1, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 60 10}] +bar + = \ (xs_axe :: [Int]) -> + GHC.Types.: + @Int + (GHC.Types.I# 0#) + (shared + @[] + Foo.$fMyFunctor[] + (GHC.Classes.(%%) + `cast` (Sub (Sym (Foo.D:R:Domain[]a[0] <Int>_N)) + :: (() :: Constraint) ~R# Domain [] Int)) + xs_axe) + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sHj :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$trModule_sHj = "main"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sHk :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$trModule_sHk = GHC.Types.TrNameS $trModule_sHj + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$trModule_sHl :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}] +$trModule_sHl = "Foo"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$trModule_sHm :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$trModule_sHm = GHC.Types.TrNameS $trModule_sHl + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +Foo.$trModule :: GHC.Types.Module +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +Foo.$trModule = GHC.Types.Module $trModule_sHk $trModule_sHm + +-- RHS size: {terms: 3, types: 1, coercions: 0, joins: 0/0} +$krep_aGA [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aGA + = GHC.Types.KindRepTyConApp + GHC.Types.$tcConstraint (GHC.Types.[] @GHC.Types.KindRep) + +-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0} +$krep_aGz [InlPrag=[~]] :: GHC.Types.KindRep +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$krep_aGz = GHC.Types.KindRepFun GHC.Types.krep$*Arr* $krep_aGA + +-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0} +$tcMyFunctor_sHn :: GHC.Prim.Addr# +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 40 0}] +$tcMyFunctor_sHn = "MyFunctor"# + +-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0} +$tcMyFunctor_sHo :: GHC.Types.TrName +[LclId, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +$tcMyFunctor_sHo = GHC.Types.TrNameS $tcMyFunctor_sHn + +-- RHS size: {terms: 7, types: 0, coercions: 0, joins: 0/0} +Foo.$tcMyFunctor :: GHC.Types.TyCon +[LclIdX, + Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True, + WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}] +Foo.$tcMyFunctor + = GHC.Types.TyCon + 12837160846121910345##64 + 787075802864859973##64 + Foo.$trModule + $tcMyFunctor_sHo + 0# + $krep_aGz + diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T index 8cdf5a5417..02a5de56c6 100644 --- a/testsuite/tests/simplCore/should_compile/all.T +++ b/testsuite/tests/simplCore/should_compile/all.T @@ -136,7 +136,9 @@ test('T5366', test('T7796', [], makefile_test, ['T7796']) test('T5550', omit_ways(prof_ways), compile, ['']) test('T7865', normal, makefile_test, ['T7865']) -test('T7785', only_ways(['optasm']), compile, ['-ddump-rules']) +# T7785: Check that we generate the specialising RULE. Might not be listed in +# -ddump-rules because of Note [Trimming auto-rules], hence grep +test('T7785', [ only_ways(['optasm']), grep_errmsg(r'RULE') ], compile, ['-ddump-spec']) test('T7702', [extra_files(['T7702plugin']), pre_cmd('$MAKE -s --no-print-directory -C T7702plugin package.T7702 TOP={top}'), @@ -308,9 +310,6 @@ test('T17901', makefile_test, ['T17901']) test('T17930', [ grep_errmsg(r'^\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques -dsuppress-idinfo']) test('spec004', [ grep_errmsg(r'\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques']) -test('T17966', - normal, - makefile_test, ['T17966']) # NB: T17810: -fspecialise-aggressively test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0']) test('T18013', normal, multimod_compile, ['T18013', '-v0 -O']) @@ -399,3 +398,8 @@ test('T20040', [ grep_errmsg(r'ifoldl\''), expect_broken(20040) ], compile, ['-O # Key here is that yes* become visibly trivial due to eta-reduction, while no* are not eta-reduced. test('T21261', [ grep_errmsg(r'^(yes|no)') ], compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-all -dsuppress-uniques']) + +# We expect to see a SPEC rule for $cm +test('T17966', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-spec']) +# We expect to see a SPEC rule for $cm +test('T19644', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-spec']) |