Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
-
be412c3e
by Andreas Klebinger at 2025-05-19T13:59:09+02:00
15 changed files:
- compiler/GHC/Core/Opt/Specialise.hs
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/InertSet.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Utils/TcType.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.hs
- + testsuite/tests/perf/should_run/SpecTyFamRun.stdout
- + testsuite/tests/perf/should_run/SpecTyFam_Import.hs
- testsuite/tests/perf/should_run/all.T
- + testsuite/tests/simplCore/should_compile/SpecTyFam.hs
- + testsuite/tests/simplCore/should_compile/SpecTyFam.stderr
- + testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
| 1 | +{-# LANGUAGE MultiWayIf #-}
|
|
| 2 | + |
|
| 1 | 3 | {-
|
| 2 | 4 | (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
|
| 3 | 5 | |
| ... | ... | @@ -14,9 +16,9 @@ import GHC.Driver.Config.Diagnostic |
| 14 | 16 | import GHC.Driver.Config.Core.Rules ( initRuleOpts )
|
| 15 | 17 | |
| 16 | 18 | import GHC.Core.Type hiding( substTy, substCo, extendTvSubst, zapSubst )
|
| 17 | -import GHC.Core.Multiplicity
|
|
| 18 | -import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith )
|
|
| 19 | +import GHC.Core.SimpleOpt( defaultSimpleOpts, simpleOptExprWith, exprIsConApp_maybe )
|
|
| 19 | 20 | import GHC.Core.Predicate
|
| 21 | +import GHC.Core.Class( classMethods )
|
|
| 20 | 22 | import GHC.Core.Coercion( Coercion )
|
| 21 | 23 | import GHC.Core.Opt.Monad
|
| 22 | 24 | import qualified GHC.Core.Subst as Core
|
| ... | ... | @@ -26,16 +28,16 @@ import GHC.Core.Make ( mkLitRubbish ) |
| 26 | 28 | import GHC.Core.Unify ( tcMatchTy )
|
| 27 | 29 | import GHC.Core.Rules
|
| 28 | 30 | import GHC.Core.Utils ( exprIsTrivial, exprIsTopLevelBindable
|
| 29 | - , mkCast, exprType
|
|
| 31 | + , mkCast, exprType, exprIsHNF
|
|
| 30 | 32 | , stripTicksTop, mkInScopeSetBndrs )
|
| 31 | 33 | import GHC.Core.FVs
|
| 32 | 34 | import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
|
| 33 | 35 | import GHC.Core.Opt.Arity( collectBindersPushingCo )
|
| 34 | --- import GHC.Core.Ppr( pprIds )
|
|
| 36 | +import GHC.Core.Ppr( pprIds )
|
|
| 35 | 37 | |
| 36 | 38 | import GHC.Builtin.Types ( unboxedUnitTy )
|
| 37 | 39 | |
| 38 | -import GHC.Data.Maybe ( maybeToList, isJust )
|
|
| 40 | +import GHC.Data.Maybe ( maybeToList, isJust, expectJust )
|
|
| 39 | 41 | import GHC.Data.Bag
|
| 40 | 42 | import GHC.Data.OrdList
|
| 41 | 43 | import GHC.Data.List.SetOps
|
| ... | ... | @@ -64,8 +66,12 @@ import GHC.Unit.Module.ModGuts |
| 64 | 66 | import GHC.Core.Unfold
|
| 65 | 67 | |
| 66 | 68 | import Data.List( partition )
|
| 67 | -import Data.List.NonEmpty ( NonEmpty (..) )
|
|
| 69 | +import Data.List.NonEmpty as NE( nonEmpty, NonEmpty(..) )
|
|
| 68 | 70 | import GHC.Core.Subst (substTickish)
|
| 71 | +import GHC.Core.TyCon (tyConClass_maybe)
|
|
| 72 | +import GHC.Core.DataCon (dataConTyCon)
|
|
| 73 | + |
|
| 74 | +import Control.Monad
|
|
| 69 | 75 | |
| 70 | 76 | {-
|
| 71 | 77 | ************************************************************************
|
| ... | ... | @@ -1279,9 +1285,9 @@ specCase :: SpecEnv |
| 1279 | 1285 | , UsageDetails)
|
| 1280 | 1286 | specCase env scrut' case_bndr [Alt con args rhs]
|
| 1281 | 1287 | | -- See Note [Floating dictionaries out of cases]
|
| 1282 | - interestingDict scrut' (idType case_bndr)
|
|
| 1288 | + interestingDict env scrut'
|
|
| 1283 | 1289 | , not (isDeadBinder case_bndr && null sc_args')
|
| 1284 | - = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
|
|
| 1290 | + = do { case_bndr_flt : sc_args_flt <- mapM clone_me (case_bndr' : sc_args')
|
|
| 1285 | 1291 | |
| 1286 | 1292 | ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
|
| 1287 | 1293 | scrut_bind = mkDB (NonRec case_bndr_flt scrut')
|
| ... | ... | @@ -1317,7 +1323,8 @@ specCase env scrut' case_bndr [Alt con args rhs] |
| 1317 | 1323 | -- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
|
| 1318 | 1324 | ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
|
| 1319 | 1325 | where
|
| 1320 | - (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
|
|
| 1326 | + (env_rhs, bndrs'::[CoreBndr]) = substBndrs env (case_bndr:args)
|
|
| 1327 | + (case_bndr':|args') = expectJust (NE.nonEmpty bndrs' :: Maybe (NonEmpty CoreBndr))
|
|
| 1321 | 1328 | sc_args' = filter is_flt_sc_arg args'
|
| 1322 | 1329 | |
| 1323 | 1330 | clone_me bndr = do { uniq <- getUniqueM
|
| ... | ... | @@ -1332,7 +1339,6 @@ specCase env scrut' case_bndr [Alt con args rhs] |
| 1332 | 1339 | arg_set = mkVarSet args'
|
| 1333 | 1340 | is_flt_sc_arg var = isId var
|
| 1334 | 1341 | && not (isDeadBinder var)
|
| 1335 | - && isDictTy var_ty
|
|
| 1336 | 1342 | && tyCoVarsOfType var_ty `disjointVarSet` arg_set
|
| 1337 | 1343 | where
|
| 1338 | 1344 | var_ty = idType var
|
| ... | ... | @@ -1644,9 +1650,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
| 1644 | 1650 | -- switch off specialisation for inline functions
|
| 1645 | 1651 | |
| 1646 | 1652 | = -- pprTrace "specCalls: some" (vcat
|
| 1647 | - -- [ text "function" <+> ppr fn
|
|
| 1648 | - -- , text "calls:" <+> ppr calls_for_me
|
|
| 1649 | - -- , text "subst" <+> ppr (se_subst env) ]) $
|
|
| 1653 | + -- [ text "function" <+> ppr fn
|
|
| 1654 | + -- , text "calls:" <+> ppr calls_for_me
|
|
| 1655 | + -- , text "subst" <+> ppr (se_subst env) ]) $
|
|
| 1650 | 1656 | foldlM spec_call ([], [], emptyUDs) calls_for_me
|
| 1651 | 1657 | |
| 1652 | 1658 | | otherwise -- No calls or RHS doesn't fit our preconceptions
|
| ... | ... | @@ -1694,21 +1700,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
| 1694 | 1700 | , rule_bndrs, rule_lhs_args
|
| 1695 | 1701 | , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
|
| 1696 | 1702 | |
| 1697 | --- ; pprTrace "spec_call" (vcat
|
|
| 1698 | --- [ text "fun: " <+> ppr fn
|
|
| 1699 | --- , text "call info: " <+> ppr _ci
|
|
| 1700 | --- , text "useful: " <+> ppr useful
|
|
| 1701 | --- , text "rule_bndrs:" <+> ppr rule_bndrs
|
|
| 1702 | --- , text "lhs_args: " <+> ppr rule_lhs_args
|
|
| 1703 | --- , text "spec_bndrs1:" <+> ppr spec_bndrs1
|
|
| 1704 | --- , text "leftover_bndrs:" <+> pprIds leftover_bndrs
|
|
| 1705 | --- , text "spec_args: " <+> ppr spec_args
|
|
| 1706 | --- , text "dx_binds: " <+> ppr dx_binds
|
|
| 1707 | --- , text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
| 1708 | --- , text "rhs_body" <+> ppr rhs_body
|
|
| 1709 | --- , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
|
|
| 1710 | --- , ppr dx_binds ]) $
|
|
| 1711 | --- return ()
|
|
| 1703 | + ; when False $ pprTrace "spec_call" (vcat
|
|
| 1704 | + [ text "fun: " <+> ppr fn
|
|
| 1705 | + , text "call info: " <+> ppr _ci
|
|
| 1706 | + , text "useful: " <+> ppr useful
|
|
| 1707 | + , text "rule_bndrs:" <+> ppr rule_bndrs
|
|
| 1708 | + , text "lhs_args: " <+> ppr rule_lhs_args
|
|
| 1709 | + , text "spec_bndrs1:" <+> ppr spec_bndrs1
|
|
| 1710 | + , text "leftover_bndrs:" <+> pprIds leftover_bndrs
|
|
| 1711 | + , text "spec_args: " <+> ppr spec_args
|
|
| 1712 | + , text "dx_binds: " <+> ppr dx_binds
|
|
| 1713 | + , text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
| 1714 | + , text "rhs_body" <+> ppr rhs_body
|
|
| 1715 | + , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
|
|
| 1716 | + , ppr dx_binds ]) $
|
|
| 1717 | + return ()
|
|
| 1712 | 1718 | |
| 1713 | 1719 | ; let all_rules = rules_acc ++ existing_rules
|
| 1714 | 1720 | -- all_rules: we look both in the rules_acc (generated by this invocation
|
| ... | ... | @@ -3102,30 +3108,15 @@ mkCallUDs' env f args |
| 3102 | 3108 | -- For "invisibleFunArg", which are the type-class dictionaries,
|
| 3103 | 3109 | -- we decide on a case by case basis if we want to specialise
|
| 3104 | 3110 | -- on this argument; if so, SpecDict, if not UnspecArg
|
| 3105 | - mk_spec_arg arg (Anon pred af)
|
|
| 3111 | + mk_spec_arg arg (Anon _pred af)
|
|
| 3106 | 3112 | | isInvisibleFunArg af
|
| 3107 | - , interestingDict arg (scaledThing pred)
|
|
| 3113 | + , interestingDict env arg
|
|
| 3114 | + -- , interestingDict arg (scaledThing pred)
|
|
| 3108 | 3115 | -- See Note [Interesting dictionary arguments]
|
| 3109 | 3116 | = SpecDict arg
|
| 3110 | 3117 | |
| 3111 | 3118 | | otherwise = UnspecArg
|
| 3112 | 3119 | |
| 3113 | -{-
|
|
| 3114 | -Note [Ticks on applications]
|
|
| 3115 | -~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 3116 | -Ticks such as source location annotations can sometimes make their way
|
|
| 3117 | -onto applications (see e.g. #21697). So if we see something like
|
|
| 3118 | - |
|
| 3119 | - App (Tick _ f) e
|
|
| 3120 | - |
|
| 3121 | -we need to descend below the tick to find what the real function being
|
|
| 3122 | -applied is.
|
|
| 3123 | - |
|
| 3124 | -The resulting RULE also has to be able to match this annotated use
|
|
| 3125 | -site, so we only look through ticks that RULE matching looks through
|
|
| 3126 | -(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
|
|
| 3127 | --}
|
|
| 3128 | - |
|
| 3129 | 3120 | wantCallsFor :: SpecEnv -> Id -> Bool
|
| 3130 | 3121 | -- See Note [wantCallsFor]
|
| 3131 | 3122 | wantCallsFor _env f
|
| ... | ... | @@ -3145,8 +3136,60 @@ wantCallsFor _env f |
| 3145 | 3136 | WorkerLikeId {} -> True
|
| 3146 | 3137 | RepPolyId {} -> True
|
| 3147 | 3138 | |
| 3148 | -{- Note [wantCallsFor]
|
|
| 3149 | -~~~~~~~~~~~~~~~~~~~~~~
|
|
| 3139 | +interestingDict :: SpecEnv -> CoreExpr -> Bool
|
|
| 3140 | +-- This is a subtle and important function
|
|
| 3141 | +-- See Note [Interesting dictionary arguments]
|
|
| 3142 | +interestingDict env (Var v) -- See (ID3) and (ID5)
|
|
| 3143 | + | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)
|
|
| 3144 | + -- might fail for loop breaker dicts but that seems fine.
|
|
| 3145 | + = interestingDict env rhs
|
|
| 3146 | + |
|
| 3147 | +interestingDict env arg -- Main Plan: use exprIsConApp_maybe
|
|
| 3148 | + | Cast inner_arg _ <- arg -- See (ID5)
|
|
| 3149 | + = if | isConstraintKind $ typeKind $ exprType inner_arg
|
|
| 3150 | + -- If coercions were always homo-kinded, we'd know
|
|
| 3151 | + -- that this would be the only case
|
|
| 3152 | + -> interestingDict env inner_arg
|
|
| 3153 | + |
|
| 3154 | + -- Check for an implicit parameter at the top
|
|
| 3155 | + | Just (cls,_) <- getClassPredTys_maybe arg_ty
|
|
| 3156 | + , isIPClass cls -- See (ID4)
|
|
| 3157 | + -> False
|
|
| 3158 | + |
|
| 3159 | + -- Otherwise we are unwrapping a unary type class
|
|
| 3160 | + | otherwise
|
|
| 3161 | + -> exprIsHNF arg -- See (ID7)
|
|
| 3162 | + |
|
| 3163 | + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg
|
|
| 3164 | + , Just cls <- tyConClass_maybe (dataConTyCon data_con)
|
|
| 3165 | + , not_ip_like -- See (ID4)
|
|
| 3166 | + = if null (classMethods cls) -- See (ID6)
|
|
| 3167 | + then any (interestingDict env) args
|
|
| 3168 | + else True
|
|
| 3169 | + |
|
| 3170 | + | otherwise
|
|
| 3171 | + = not (exprIsTrivial arg) && not_ip_like -- See (ID8)
|
|
| 3172 | + where
|
|
| 3173 | + arg_ty = exprType arg
|
|
| 3174 | + not_ip_like = not (couldBeIPLike arg_ty)
|
|
| 3175 | + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding
|
|
| 3176 | + |
|
| 3177 | +{- Note [Ticks on applications]
|
|
| 3178 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 3179 | +Ticks such as source location annotations can sometimes make their way
|
|
| 3180 | +onto applications (see e.g. #21697). So if we see something like
|
|
| 3181 | + |
|
| 3182 | + App (Tick _ f) e
|
|
| 3183 | + |
|
| 3184 | +we need to descend below the tick to find what the real function being
|
|
| 3185 | +applied is.
|
|
| 3186 | + |
|
| 3187 | +The resulting RULE also has to be able to match this annotated use
|
|
| 3188 | +site, so we only look through ticks that RULE matching looks through
|
|
| 3189 | +(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
|
|
| 3190 | + |
|
| 3191 | +Note [wantCallsFor]
|
|
| 3192 | +~~~~~~~~~~~~~~~~~~~
|
|
| 3150 | 3193 | `wantCallsFor env f` says whether the Specialiser should collect calls for
|
| 3151 | 3194 | function `f`; other thing being equal, the fewer calls we collect the better. It
|
| 3152 | 3195 | is False for things we can't specialise:
|
| ... | ... | @@ -3172,44 +3215,91 @@ collect usage info for imported overloaded functions. |
| 3172 | 3215 | |
| 3173 | 3216 | Note [Interesting dictionary arguments]
|
| 3174 | 3217 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| 3175 | -In `mkCallUDs` we only use `SpecDict` for dictionaries of which
|
|
| 3176 | -`interestingDict` holds. Otherwise we use `UnspecArg`. Two reasons:
|
|
| 3177 | - |
|
| 3178 | -* Consider this
|
|
| 3179 | - \a.\d:Eq a. let f = ... in ...(f d)...
|
|
| 3180 | - There really is not much point in specialising f wrt the dictionary d,
|
|
| 3181 | - because the code for the specialised f is not improved at all, because
|
|
| 3182 | - d is lambda-bound. We simply get junk specialisations.
|
|
| 3183 | - |
|
| 3184 | -* Consider this (#25703):
|
|
| 3185 | - f :: (Eq a, Show b) => a -> b -> INt
|
|
| 3186 | - goo :: forall x. (Eq x) => x -> blah
|
|
| 3187 | - goo @x (d:Eq x) (arg:x) = ...(f @x @Int d $fShowInt)...
|
|
| 3188 | - If we built a `ci_key` with a (SpecDict d) for `d`, we would end up
|
|
| 3189 | - discarding the call at the `\d`. But if we use `UnspecArg` for that
|
|
| 3190 | - uninteresting `d`, we'll get a `ci_key` of
|
|
| 3191 | - f @x @Int UnspecArg (SpecDict $fShowInt)
|
|
| 3192 | - and /that/ can float out to f's definition and specialise nicely.
|
|
| 3193 | - Hooray. (NB: the call can float only if `-fpolymorphic-specialisation`
|
|
| 3194 | - is on; otherwise it'll be trapped by the `\@x -> ...`.)(
|
|
| 3195 | - |
|
| 3196 | -What is "interesting"? (See `interestingDict`.) Just that it has *some*
|
|
| 3197 | -structure. But what about variables? We look in the variable's /unfolding/.
|
|
| 3198 | -And that means that we must be careful to ensure that dictionaries /have/
|
|
| 3199 | -unfoldings,
|
|
| 3200 | - |
|
| 3201 | -* cloneBndrSM discards non-Stable unfoldings
|
|
| 3202 | -* specBind updates the unfolding after specialisation
|
|
| 3203 | - See Note [Update unfolding after specialisation]
|
|
| 3204 | -* bindAuxiliaryDict adds an unfolding for an aux dict
|
|
| 3205 | - see Note [Specialisation modulo dictionary selectors]
|
|
| 3206 | -* specCase adds unfoldings for the new bindings it creates
|
|
| 3207 | - |
|
| 3208 | -We accidentally lost accurate tracking of local variables for a long
|
|
| 3209 | -time, because cloned variables didn't have unfoldings. But makes a
|
|
| 3210 | -massive difference in a few cases, eg #5113. For nofib as a
|
|
| 3211 | -whole it's only a small win: 2.2% improvement in allocation for ansi,
|
|
| 3212 | -1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
|
|
| 3218 | +Consider this
|
|
| 3219 | + \a.\d:Eq a. let f = ... in ...(f d)...
|
|
| 3220 | +There really is not much point in specialising f wrt the dictionary d,
|
|
| 3221 | +because the code for the specialised f is not improved at all, because
|
|
| 3222 | +d is lambda-bound. We simply get junk specialisations.
|
|
| 3223 | + |
|
| 3224 | +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see
|
|
| 3225 | +if the argument is a dictionary constructor applied to some arguments, in which
|
|
| 3226 | +case we can clearly specialise. But there are wrinkles:
|
|
| 3227 | + |
|
| 3228 | +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the
|
|
| 3229 | + argument is
|
|
| 3230 | + (% d1, d2 %) |> co
|
|
| 3231 | + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.
|
|
| 3232 | + Then its type (F Int a) looks very un-informative, but the term is super
|
|
| 3233 | + helpful. See #19747 (where missing this point caused a 70x slow down)
|
|
| 3234 | + and #7785.
|
|
| 3235 | + |
|
| 3236 | +(ID2) Note that the Main Plan works fine for an argument that is a DFun call,
|
|
| 3237 | + e.g. $fOrdList $dOrdInt
|
|
| 3238 | + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good!
|
|
| 3239 | + |
|
| 3240 | +(ID3) For variables, we look in the variable's /unfolding/. And that means
|
|
| 3241 | + that we must be careful to ensure that dictionaries /have/ unfoldings:
|
|
| 3242 | + * cloneBndrSM discards non-Stable unfoldings
|
|
| 3243 | + * specBind updates the unfolding after specialisation
|
|
| 3244 | + See Note [Update unfolding after specialisation]
|
|
| 3245 | + * bindAuxiliaryDict adds an unfolding for an aux dict
|
|
| 3246 | + see Note [Specialisation modulo dictionary selectors]
|
|
| 3247 | + * specCase adds unfoldings for the new bindings it creates
|
|
| 3248 | + |
|
| 3249 | + We accidentally lost accurate tracking of local variables for a long
|
|
| 3250 | + time, because cloned variables didn't have unfoldings. But makes a
|
|
| 3251 | + massive difference in a few cases, eg #5113. For nofib as a
|
|
| 3252 | + whole it's only a small win: 2.2% improvement in allocation for ansi,
|
|
| 3253 | + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
|
|
| 3254 | + |
|
| 3255 | +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains
|
|
| 3256 | + an implicit parameter, because implicit parameters are emphatically not singleton
|
|
| 3257 | + types. See #25999:
|
|
| 3258 | + useImplicit :: (?i :: Int) => Int
|
|
| 3259 | + useImplicit = ?i + 1
|
|
| 3260 | + |
|
| 3261 | + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)
|
|
| 3262 | + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.
|
|
| 3263 | + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`.
|
|
| 3264 | + |
|
| 3265 | +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal
|
|
| 3266 | + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type
|
|
| 3267 | + constructor at the top of both sides. But see the example in (ID1), where that
|
|
| 3268 | + is not true. For thes same reason, we can't rely on `exprIsConApp_maybe` to look
|
|
| 3269 | + through unfoldings (because there might be a cast inside), hence dealing with
|
|
| 3270 | + expandable unfoldings in `interestingDict` directly.
|
|
| 3271 | + |
|
| 3272 | +(ID6) The Main Plan says that it's worth specialising if the argument is an application
|
|
| 3273 | + of a dictionary contructor. But what if the dictionary has no methods? Then we
|
|
| 3274 | + gain nothing by specialising, unless the /superclasses/ are interesting. A case
|
|
| 3275 | + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class
|
|
| 3276 | + with N superclasses and no methods.
|
|
| 3277 | + |
|
| 3278 | +(ID7) A unary (single-method) class is currently represented by (meth |> co). We
|
|
| 3279 | + will unwrap the cast (see (ID5)) and then want to reply "yes" if the method
|
|
| 3280 | + has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a
|
|
| 3281 | + new story for unary classes, see #23109, and this special case will become
|
|
| 3282 | + irrelevant.)
|
|
| 3283 | + |
|
| 3284 | +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a
|
|
| 3285 | + non-trivial argument as interesting. In T19695 we have this:
|
|
| 3286 | + askParams :: Monad m => blah
|
|
| 3287 | + mhelper :: MonadIO m => blah
|
|
| 3288 | + mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....
|
|
| 3289 | + where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is
|
|
| 3290 | + specialised at `Handler` we'll get this call in the specialised `$smhelper`:
|
|
| 3291 | + askParams @Handler ($p1 $fMonadIOHandler)
|
|
| 3292 | + and we /definitely/ want to specialise that, even though the argument isn't
|
|
| 3293 | + visibly a dictionary application. In fact the specialiser fires the superclass
|
|
| 3294 | + selector rule (see Note [Fire rules in the specialiser]), so we get
|
|
| 3295 | + askParams @Handler ($cp1MonadIO $fMonadIOIO)
|
|
| 3296 | + but it /still/ doesn't look like a dictionary application.
|
|
| 3297 | + |
|
| 3298 | + Conclusion: we optimistically assume that any non-trivial argument is worth
|
|
| 3299 | + specialising on.
|
|
| 3300 | + |
|
| 3301 | + So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look
|
|
| 3302 | + under type-family casts (ID1) and constraint tuples (ID6).
|
|
| 3213 | 3303 | |
| 3214 | 3304 | Note [Update unfolding after specialisation]
|
| 3215 | 3305 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
| ... | ... | @@ -3237,6 +3327,7 @@ Consider (#21848) |
| 3237 | 3327 | Now `f` turns into:
|
| 3238 | 3328 | |
| 3239 | 3329 | f @a @b (dd :: D a) (ds :: Show b) a b
|
| 3330 | + |
|
| 3240 | 3331 | = let dc :: D a = %p1 dd -- Superclass selection
|
| 3241 | 3332 | in meth @a dc ....
|
| 3242 | 3333 | meth @a dc ....
|
| ... | ... | @@ -3252,27 +3343,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with |
| 3252 | 3343 | the Rec case.)
|
| 3253 | 3344 | -}
|
| 3254 | 3345 | |
| 3255 | -interestingDict :: CoreExpr -> Type -> Bool
|
|
| 3256 | --- A dictionary argument is interesting if it has *some* structure,
|
|
| 3257 | --- see Note [Interesting dictionary arguments]
|
|
| 3258 | --- NB: "dictionary" arguments include constraints of all sorts,
|
|
| 3259 | --- including equality constraints; hence the Coercion case
|
|
| 3260 | --- To make this work, we need to ensure that dictionaries have
|
|
| 3261 | --- unfoldings in them.
|
|
| 3262 | -interestingDict arg arg_ty
|
|
| 3263 | - | not (typeDeterminesValue arg_ty) = False -- See Note [Type determines value]
|
|
| 3264 | - | otherwise = go arg
|
|
| 3265 | - where
|
|
| 3266 | - go (Var v) = hasSomeUnfolding (idUnfolding v)
|
|
| 3267 | - || isDataConWorkId v
|
|
| 3268 | - go (Type _) = False
|
|
| 3269 | - go (Coercion _) = False
|
|
| 3270 | - go (App fn (Type _)) = go fn
|
|
| 3271 | - go (App fn (Coercion _)) = go fn
|
|
| 3272 | - go (Tick _ a) = go a
|
|
| 3273 | - go (Cast e _) = go e
|
|
| 3274 | - go _ = True
|
|
| 3275 | - |
|
| 3276 | 3346 | thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
|
| 3277 | 3347 | thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
|
| 3278 | 3348 | (MkUD {ud_binds = db2, ud_calls = calls2})
|
| ... | ... | @@ -24,7 +24,7 @@ module GHC.Core.Predicate ( |
| 24 | 24 | classMethodTy, classMethodInstTy,
|
| 25 | 25 | |
| 26 | 26 | -- Implicit parameters
|
| 27 | - isIPLikePred, mentionsIP, isIPTyCon, isIPClass,
|
|
| 27 | + couldBeIPLike, mightMentionIP, isIPTyCon, isIPClass,
|
|
| 28 | 28 | isCallStackTy, isCallStackPred, isCallStackPredTy,
|
| 29 | 29 | isExceptionContextPred, isExceptionContextTy,
|
| 30 | 30 | isIPPred_maybe,
|
| ... | ... | @@ -125,9 +125,12 @@ isDictTy ty = isClassPred pred |
| 125 | 125 | where
|
| 126 | 126 | (_, pred) = splitInvisPiTys ty
|
| 127 | 127 | |
| 128 | +-- | Is the type *guaranteed* to determine the value?
|
|
| 129 | +--
|
|
| 130 | +-- Might say No even if the type does determine the value. (See the Note)
|
|
| 128 | 131 | typeDeterminesValue :: Type -> Bool
|
| 129 | 132 | -- See Note [Type determines value]
|
| 130 | -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
|
|
| 133 | +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)
|
|
| 131 | 134 | |
| 132 | 135 | getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
|
| 133 | 136 | getClassPredTys ty = case getClassPredTys_maybe ty of
|
| ... | ... | @@ -170,6 +173,10 @@ So we treat implicit params just like ordinary arguments for the |
| 170 | 173 | purposes of specialisation. Note that we still want to specialise
|
| 171 | 174 | functions with implicit params if they have *other* dicts which are
|
| 172 | 175 | class params; see #17930.
|
| 176 | + |
|
| 177 | +It's also not always possible to infer that a type determines the value
|
|
| 178 | +if type families are in play. See #19747 for one such example.
|
|
| 179 | + |
|
| 173 | 180 | -}
|
| 174 | 181 | |
| 175 | 182 | -- --------------------- Equality predicates ---------------------------------
|
| ... | ... | @@ -410,44 +417,44 @@ isCallStackTy ty |
| 410 | 417 | | otherwise
|
| 411 | 418 | = False
|
| 412 | 419 | |
| 413 | --- --------------------- isIPLike and mentionsIP --------------------------
|
|
| 420 | +-- --------------------- couldBeIPLike and mightMentionIP --------------------------
|
|
| 414 | 421 | -- See Note [Local implicit parameters]
|
| 415 | 422 | |
| 416 | -isIPLikePred :: Type -> Bool
|
|
| 423 | +couldBeIPLike :: Type -> Bool
|
|
| 417 | 424 | -- Is `pred`, or any of its superclasses, an implicit parameter?
|
| 418 | 425 | -- See Note [Local implicit parameters]
|
| 419 | -isIPLikePred pred =
|
|
| 420 | - mentions_ip_pred initIPRecTc (const True) (const True) pred
|
|
| 421 | - |
|
| 422 | -mentionsIP :: (Type -> Bool) -- ^ predicate on the string
|
|
| 423 | - -> (Type -> Bool) -- ^ predicate on the type
|
|
| 424 | - -> Class
|
|
| 425 | - -> [Type] -> Bool
|
|
| 426 | --- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
|
|
| 426 | +couldBeIPLike pred
|
|
| 427 | + = might_mention_ip1 initIPRecTc (const True) (const True) pred
|
|
| 428 | + |
|
| 429 | +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string
|
|
| 430 | + -> (Type -> Bool) -- ^ predicate on the type
|
|
| 431 | + -> Class
|
|
| 432 | + -> [Type] -> Bool
|
|
| 433 | +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:
|
|
| 427 | 434 | --
|
| 428 | 435 | -- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
|
| 429 | 436 | -- are both @True@,
|
| 430 | 437 | -- - or any superclass of @cls tys@ has this property.
|
| 431 | 438 | --
|
| 432 | 439 | -- See Note [Local implicit parameters]
|
| 433 | -mentionsIP = mentions_ip initIPRecTc
|
|
| 440 | +mightMentionIP = might_mention_ip initIPRecTc
|
|
| 434 | 441 | |
| 435 | -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
|
|
| 436 | -mentions_ip rec_clss str_cond ty_cond cls tys
|
|
| 442 | +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
|
|
| 443 | +might_mention_ip rec_clss str_cond ty_cond cls tys
|
|
| 437 | 444 | | Just (str_ty, ty) <- isIPPred_maybe cls tys
|
| 438 | 445 | = str_cond str_ty && ty_cond ty
|
| 439 | 446 | | otherwise
|
| 440 | - = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
|
|
| 447 | + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
|
|
| 441 | 448 | | sc_sel_id <- classSCSelIds cls ]
|
| 442 | 449 | |
| 443 | 450 | |
| 444 | -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
|
|
| 445 | -mentions_ip_pred rec_clss str_cond ty_cond ty
|
|
| 451 | +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
|
|
| 452 | +might_mention_ip1 rec_clss str_cond ty_cond ty
|
|
| 446 | 453 | | Just (cls, tys) <- getClassPredTys_maybe ty
|
| 447 | 454 | , let tc = classTyCon cls
|
| 448 | 455 | , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
|
| 449 | 456 | else checkRecTc rec_clss tc
|
| 450 | - = mentions_ip rec_clss' str_cond ty_cond cls tys
|
|
| 457 | + = might_mention_ip rec_clss' str_cond ty_cond cls tys
|
|
| 451 | 458 | | otherwise
|
| 452 | 459 | = False -- Includes things like (D []) where D is
|
| 453 | 460 | -- a Constraint-ranged family; #7785
|
| ... | ... | @@ -460,7 +467,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc |
| 460 | 467 | See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in
|
| 461 | 468 | GHC.Tc.Solver.Dict.
|
| 462 | 469 | |
| 463 | -The function isIPLikePred tells if this predicate, or any of its
|
|
| 470 | +The function couldBeIPLike tells if this predicate, or any of its
|
|
| 464 | 471 | superclasses, is an implicit parameter.
|
| 465 | 472 | |
| 466 | 473 | Why are implicit parameters special? Unlike normal classes, we can
|
| ... | ... | @@ -468,7 +475,7 @@ have local instances for implicit parameters, in the form of |
| 468 | 475 | let ?x = True in ...
|
| 469 | 476 | So in various places we must be careful not to assume that any value
|
| 470 | 477 | of the right type will do; we must carefully look for the innermost binding.
|
| 471 | -So isIPLikePred checks whether this is an implicit parameter, or has
|
|
| 478 | +So couldBeIPLike checks whether this is an implicit parameter, or has
|
|
| 472 | 479 | a superclass that is an implicit parameter.
|
| 473 | 480 | |
| 474 | 481 | Several wrinkles
|
| ... | ... | @@ -509,16 +516,16 @@ Small worries (Sept 20): |
| 509 | 516 | think nothing does.
|
| 510 | 517 | * I'm a little concerned about type variables; such a variable might
|
| 511 | 518 | be instantiated to an implicit parameter. I don't think this
|
| 512 | - matters in the cases for which isIPLikePred is used, and it's pretty
|
|
| 519 | + matters in the cases for which couldBeIPLike is used, and it's pretty
|
|
| 513 | 520 | obscure anyway.
|
| 514 | 521 | * The superclass hunt stops when it encounters the same class again,
|
| 515 | 522 | but in principle we could have the same class, differently instantiated,
|
| 516 | 523 | and the second time it could have an implicit parameter
|
| 517 | 524 | I'm going to treat these as problems for another day. They are all exotic.
|
| 518 | 525 | |
| 519 | -Note [Using typesAreApart when calling mentionsIP]
|
|
| 520 | -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 521 | -We call 'mentionsIP' in two situations:
|
|
| 526 | +Note [Using typesAreApart when calling mightMentionIP]
|
|
| 527 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 528 | +We call 'mightMentionIP' in two situations:
|
|
| 522 | 529 | |
| 523 | 530 | (1) to check that a predicate does not contain any implicit parameters
|
| 524 | 531 | IP str ty, for a fixed literal str and any type ty,
|
| ... | ... | @@ -1928,7 +1928,7 @@ growThetaTyVars theta tcvs |
| 1928 | 1928 | | otherwise = transCloVarSet mk_next seed_tcvs
|
| 1929 | 1929 | where
|
| 1930 | 1930 | seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
|
| 1931 | - (ips, non_ips) = partition isIPLikePred theta
|
|
| 1931 | + (ips, non_ips) = partition couldBeIPLike theta
|
|
| 1932 | 1932 | -- See Note [Inheriting implicit parameters]
|
| 1933 | 1933 | |
| 1934 | 1934 | mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
|
| ... | ... | @@ -749,7 +749,7 @@ shortCutSolver dflags ev_w ev_i |
| 749 | 749 | -- programs should typecheck regardless of whether we take this step or
|
| 750 | 750 | -- not. See Note [Shortcut solving]
|
| 751 | 751 | |
| 752 | - , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
|
|
| 752 | + , not (couldBeIPLike (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
|
|
| 753 | 753 | |
| 754 | 754 | , not (xopt LangExt.IncoherentInstances dflags)
|
| 755 | 755 | -- If IncoherentInstances is on then we cannot rely on coherence of proofs
|
| ... | ... | @@ -2043,10 +2043,10 @@ solveOneFromTheOther ct_i ct_w |
| 2043 | 2043 | is_wsc_orig_w = isWantedSuperclassOrigin orig_w
|
| 2044 | 2044 | |
| 2045 | 2045 | different_level_strategy -- Both Given
|
| 2046 | - | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
|
|
| 2047 | - | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
|
|
| 2046 | + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
|
|
| 2047 | + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
|
|
| 2048 | 2048 | -- See Note [Replacement vs keeping] part (1)
|
| 2049 | - -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
|
|
| 2049 | + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]
|
|
| 2050 | 2050 | -- in GHC.Tc.Solver.Dict
|
| 2051 | 2051 | |
| 2052 | 2052 | same_level_strategy -- Both Given
|
| ... | ... | @@ -403,8 +403,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) |
| 403 | 403 | -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
|
| 404 | 404 | does_not_mention_ip_for :: Type -> DictCt -> Bool
|
| 405 | 405 | does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
|
| 406 | - = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
|
|
| 407 | - -- See Note [Using typesAreApart when calling mentionsIP]
|
|
| 406 | + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
|
|
| 407 | + -- See Note [Using typesAreApart when calling mightMentionIP]
|
|
| 408 | 408 | -- in GHC.Core.Predicate
|
| 409 | 409 | |
| 410 | 410 | updInertIrreds :: IrredCt -> TcS ()
|
| ... | ... | @@ -544,7 +544,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) |
| 544 | 544 | = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName
|
| 545 | 545 | ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
|
| 546 | 546 | ; let contains_callstack_or_exceptionCtx =
|
| 547 | - mentionsIP
|
|
| 547 | + mightMentionIP
|
|
| 548 | 548 | (const True)
|
| 549 | 549 | -- NB: the name of the call-stack IP is irrelevant
|
| 550 | 550 | -- e.g (?foo :: CallStack) counts!
|
| ... | ... | @@ -562,9 +562,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) |
| 562 | 562 | |
| 563 | 563 | -- Return a predicate that decides whether a type is CallStack
|
| 564 | 564 | -- or ExceptionContext, accounting for e.g. type family reduction, as
|
| 565 | - -- per Note [Using typesAreApart when calling mentionsIP].
|
|
| 565 | + -- per Note [Using typesAreApart when calling mightMentionIP].
|
|
| 566 | 566 | --
|
| 567 | - -- See Note [Using isCallStackTy in mentionsIP].
|
|
| 567 | + -- See Note [Using isCallStackTy in mightMentionIP].
|
|
| 568 | 568 | is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
|
| 569 | 569 | is_tyConTy is_eq tc_name
|
| 570 | 570 | = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name
|
| ... | ... | @@ -592,14 +592,14 @@ in a different context! |
| 592 | 592 | See also Note [Shadowing of implicit parameters], which deals with a similar
|
| 593 | 593 | problem with Given implicit parameter constraints.
|
| 594 | 594 | |
| 595 | -Note [Using isCallStackTy in mentionsIP]
|
|
| 596 | -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 595 | +Note [Using isCallStackTy in mightMentionIP]
|
|
| 596 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
| 597 | 597 | To implement Note [Don't add HasCallStack constraints to the solved set],
|
| 598 | 598 | we need to check whether a constraint contains a HasCallStack or HasExceptionContext
|
| 599 | 599 | constraint. We do this using the 'mentionsIP' function, but as per
|
| 600 | -Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
|
|
| 600 | +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:
|
|
| 601 | 601 | |
| 602 | - mentionsIP
|
|
| 602 | + mightMentionIP
|
|
| 603 | 603 | (const True) -- (ignore the implicit parameter string)
|
| 604 | 604 | (isCallStackTy <||> isExceptionContextTy)
|
| 605 | 605 |
| ... | ... | @@ -155,7 +155,7 @@ module GHC.Tc.Utils.TcType ( |
| 155 | 155 | mkTyConTy, mkTyVarTy, mkTyVarTys,
|
| 156 | 156 | mkTyCoVarTy, mkTyCoVarTys,
|
| 157 | 157 | |
| 158 | - isClassPred, isEqPred, isIPLikePred, isEqClassPred,
|
|
| 158 | + isClassPred, isEqPred, couldBeIPLike, isEqClassPred,
|
|
| 159 | 159 | isEqualityClass, mkClassPred,
|
| 160 | 160 | tcSplitQuantPredTy, tcSplitDFunTy, tcSplitDFunHead, tcSplitMethodTy,
|
| 161 | 161 | isRuntimeRepVar, isFixedRuntimeRepKind,
|
| ... | ... | @@ -1819,7 +1819,7 @@ pickCapturedPreds |
| 1819 | 1819 | pickCapturedPreds qtvs theta
|
| 1820 | 1820 | = filter captured theta
|
| 1821 | 1821 | where
|
| 1822 | - captured pred = isIPLikePred pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
|
|
| 1822 | + captured pred = couldBeIPLike pred || (tyCoVarsOfType pred `intersectsVarSet` qtvs)
|
|
| 1823 | 1823 | |
| 1824 | 1824 | |
| 1825 | 1825 | -- Superclasses
|
| 1 | +{-# OPTIONS_GHC -fspecialise-aggressively #-}
|
|
| 2 | +{-# OPTIONS_GHC -fno-spec-constr #-}
|
|
| 3 | +module Main(main) where
|
|
| 4 | + |
|
| 5 | +import SpecTyFam_Import (specMe, MaybeShowNum)
|
|
| 6 | +import GHC.Exts
|
|
| 7 | + |
|
| 8 | +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
|
|
| 9 | + |
|
| 10 | +{-# NOINLINE foo #-}
|
|
| 11 | +foo :: Int -> (String,Int)
|
|
| 12 | +-- We want specMe to be specialized, but not inlined
|
|
| 13 | +foo x = specMe True x
|
|
| 14 | + |
|
| 15 | +main = print $ sum $ map (snd . foo) [1..1000 :: Int] |
| 1 | +500500 |
| 1 | +{-# LANGUAGE TypeFamilies #-}
|
|
| 2 | +{-# LANGUAGE BangPatterns #-}
|
|
| 3 | + |
|
| 4 | +module SpecTyFam_Import (specMe, MaybeShowNum) where
|
|
| 5 | + |
|
| 6 | +import Data.Kind
|
|
| 7 | + |
|
| 8 | +type family MaybeShowNum a n :: Constraint where
|
|
| 9 | + MaybeShowNum a n = (Show a, Num n)
|
|
| 10 | + |
|
| 11 | +{-# INLINABLE specMe #-}
|
|
| 12 | +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
|
|
| 13 | +specMe s !n = (show s, n+1 `div` 2) |
| ... | ... | @@ -423,3 +423,12 @@ test('ByteCodeAsm', |
| 423 | 423 | ],
|
| 424 | 424 | compile_and_run,
|
| 425 | 425 | ['-package ghc'])
|
| 426 | + |
|
| 427 | +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
|
|
| 428 | +# See also #19747
|
|
| 429 | +test('SpecTyFamRun', [ grep_errmsg(r'foo')
|
|
| 430 | + , extra_files(['SpecTyFam_Import.hs'])
|
|
| 431 | + , only_ways(['optasm'])
|
|
| 432 | + , collect_stats('bytes allocated', 5)],
|
|
| 433 | + multimod_compile_and_run,
|
|
| 434 | + ['SpecTyFamRun', '-O2']) |
| 1 | +{-# OPTIONS_GHC -fspecialise-aggressively #-}
|
|
| 2 | +{-# OPTIONS_GHC -fno-spec-constr #-}
|
|
| 3 | + |
|
| 4 | +module SpecTyFam(main, foo) where
|
|
| 5 | + |
|
| 6 | +import SpecTyFam_Import (specMe, MaybeShowNum)
|
|
| 7 | +import GHC.Exts
|
|
| 8 | + |
|
| 9 | +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
|
|
| 10 | + |
|
| 11 | +{-# OPAQUE foo #-}
|
|
| 12 | +foo :: Int -> (String,Int)
|
|
| 13 | +foo x = specMe True x
|
|
| 14 | + |
|
| 15 | +main = print $ sum $ map (snd . foo) [1..1000 :: Int] |
| 1 | +[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o )
|
|
| 2 | + |
|
| 3 | +==================== Specialise ====================
|
|
| 4 | +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1}
|
|
| 5 | + |
|
| 6 | +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1}
|
|
| 7 | +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n)
|
|
| 8 | +[LclIdX,
|
|
| 9 | + Arity=4,
|
|
| 10 | + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10
|
|
| 11 | + Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) ->
|
|
| 12 | + let {
|
|
| 13 | + $dNum :: Num n
|
|
| 14 | + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
|
|
| 15 | + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
|
|
| 16 | + case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}]
|
|
| 17 | +specMe
|
|
| 18 | + = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) ->
|
|
| 19 | + let {
|
|
| 20 | + $dNum :: Num n
|
|
| 21 | + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
|
|
| 22 | + $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
|
|
| 23 | + case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }
|
|
| 24 | + |
|
| 25 | + |
|
| 26 | + |
|
| 27 | +[2 of 2] Compiling SpecTyFam ( SpecTyFam.hs, SpecTyFam.o )
|
|
| 28 | + |
|
| 29 | +==================== Specialise ====================
|
|
| 30 | +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1}
|
|
| 31 | + |
|
| 32 | +Rec {
|
|
| 33 | +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0}
|
|
| 34 | +$dCTuple2 :: (Show Bool, Num Int)
|
|
| 35 | +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
|
|
| 36 | +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt)
|
|
| 37 | + |
|
| 38 | +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1}
|
|
| 39 | +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #)
|
|
| 40 | +[LclId, Arity=2]
|
|
| 41 | +$s$wspecMe
|
|
| 42 | + = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) ->
|
|
| 43 | + let {
|
|
| 44 | + $dNum :: Num Int
|
|
| 45 | + [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
|
|
| 46 | + $dNum = GHC.Internal.Num.$fNumInt } in
|
|
| 47 | + case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) }
|
|
| 48 | + |
|
| 49 | +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0}
|
|
| 50 | +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int)
|
|
| 51 | +[LclId,
|
|
| 52 | + Arity=2,
|
|
| 53 | + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
|
|
| 54 | + Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}]
|
|
| 55 | +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }
|
|
| 56 | +end Rec }
|
|
| 57 | + |
|
| 58 | +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0}
|
|
| 59 | +foo [InlPrag=OPAQUE] :: Int -> (String, Int)
|
|
| 60 | +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}]
|
|
| 61 | +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x
|
|
| 62 | + |
|
| 63 | +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0}
|
|
| 64 | +main :: State# RealWorld -> (# State# RealWorld, () #)
|
|
| 65 | +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}]
|
|
| 66 | +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta
|
|
| 67 | + |
|
| 68 | +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0}
|
|
| 69 | +main :: IO ()
|
|
| 70 | +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
|
|
| 71 | +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())
|
|
| 72 | + |
|
| 73 | + |
|
| 74 | +------ Local rules for imported ids --------
|
|
| 75 | +"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe
|
|
| 76 | +"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe
|
|
| 77 | + |
|
| 78 | + |
| 1 | +{-# LANGUAGE TypeFamilies #-}
|
|
| 2 | +{-# LANGUAGE BangPatterns #-}
|
|
| 3 | +{-# LANGUAGE ImplicitParams #-}
|
|
| 4 | + |
|
| 5 | +module SpecTyFam_Import (specMe, MaybeShowNum) where
|
|
| 6 | + |
|
| 7 | +import Data.Kind
|
|
| 8 | + |
|
| 9 | +type family MaybeShowNum a n :: Constraint where
|
|
| 10 | + MaybeShowNum a n = (Show a, Num n)
|
|
| 11 | + |
|
| 12 | +{-# INLINABLE specMe #-}
|
|
| 13 | +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
|
|
| 14 | +specMe s !n = (show s, n+1 `div` 2) |
| ... | ... | @@ -548,3 +548,9 @@ test('T25965', normal, compile, ['-O']) |
| 548 | 548 | test('T25703', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings'])
|
| 549 | 549 | test('T25703a', [grep_errmsg(r'SPEC')], compile, ['-O -fpolymorphic-specialisation -ddump-rule-firings'])
|
| 550 | 550 | |
| 551 | +# Check that $s$wspecMe doesn't have any dictionary args after specialization in addition to perf stats
|
|
| 552 | +test('SpecTyFam', [ grep_errmsg(r'\$wspecMe')
|
|
| 553 | + , extra_files(['SpecTyFam_Import.hs'])
|
|
| 554 | + , only_ways(['optasm'])],
|
|
| 555 | + multimod_compile,
|
|
| 556 | + ['SpecTyFam', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000']) |