Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC
Commits:
-
47feb375
by Andreas Klebinger at 2025-07-04T22:47:13+01:00
-
bdbbedae
by Simon Peyton Jones at 2025-07-04T22:47:58+01:00
-
ae8740b3
by Andreas Klebinger at 2025-07-04T22:58:58+01:00
16 changed files:
- compiler/GHC/Core/Opt/DmdAnal.hs
- 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/T26051.hs
- + testsuite/tests/simplCore/should_compile/T26051.stderr
- + testsuite/tests/simplCore/should_compile/T26051_Import.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
... | ... | @@ -23,7 +23,7 @@ import GHC.Core.DataCon |
23 | 23 | import GHC.Core.Utils
|
24 | 24 | import GHC.Core.TyCon
|
25 | 25 | import GHC.Core.Type
|
26 | -import GHC.Core.Predicate( isEqualityClass, isCTupleClass )
|
|
26 | +import GHC.Core.Predicate( isEqualityClass {- , isCTupleClass -} )
|
|
27 | 27 | import GHC.Core.FVs ( rulesRhsFreeIds, bndrRuleAndUnfoldingIds )
|
28 | 28 | import GHC.Core.Coercion ( Coercion )
|
29 | 29 | import GHC.Core.TyCo.FVs ( coVarsOfCos )
|
... | ... | @@ -2194,7 +2194,7 @@ doNotUnbox :: Type -> Bool |
2194 | 2194 | doNotUnbox arg_ty
|
2195 | 2195 | = case tyConAppTyCon_maybe arg_ty of
|
2196 | 2196 | Just tc | Just cls <- tyConClass_maybe tc
|
2197 | - -> not (isEqualityClass cls || isCTupleClass cls)
|
|
2197 | + -> not (isEqualityClass cls)
|
|
2198 | 2198 | -- See (DNB2) and (DNB1) in Note [Do not unbox class dictionaries]
|
2199 | 2199 | |
2200 | 2200 | _ -> False
|
... | ... | @@ -2232,22 +2232,32 @@ TL;DR we /never/ unbox class dictionaries. Unboxing the dictionary, and passing |
2232 | 2232 | a raft of higher-order functions isn't a huge win anyway -- you really want to
|
2233 | 2233 | specialise the function.
|
2234 | 2234 | |
2235 | -Wrinkle (DNB1): we /do/ want to unbox tuple dictionaries (#23398)
|
|
2236 | - f :: (% Eq a, Show a %) => blah
|
|
2237 | - with -fdicts-strict it is great to unbox to
|
|
2238 | - $wf :: Eq a => Show a => blah
|
|
2239 | - (where I have written out the currying explicitly). Now we can specialise
|
|
2240 | - $wf on the Eq or Show dictionary. Nothing is lost.
|
|
2241 | - |
|
2242 | - And something is gained. It is possible that `f` will look like this:
|
|
2243 | - f = /\a. \d:(% Eq a, Show a %). ... f @a (% sel1 d, sel2 d %)...
|
|
2244 | - where there is a recurive call to `f`, or to another function that takes the
|
|
2245 | - same tuple dictionary, but where the tuple is built from the components of
|
|
2246 | - `d`. The Simplier does not fix this. But if we unpacked the dictionary
|
|
2247 | - we'd get
|
|
2248 | - $wf = /\a. \(d1:Eq a) (d2:Show a). let d = (% d1, d2 %)
|
|
2249 | - in ...f @a (% sel1 d, sel2 d %)
|
|
2250 | - and all the tuple building and taking apart will disappear.
|
|
2235 | +Wrinkle (DNB1): we /do not/ to unbox tuple dictionaries either. We used to
|
|
2236 | + have a special case to unbox tuple dictionaries (#23398), but it ultimately
|
|
2237 | + turned out to be a very bad idea (see !19747#note_626297). In summary:
|
|
2238 | + |
|
2239 | + - If w/w unboxes tuple dictionaries we get things like
|
|
2240 | + case d of CTuple2 d1 d2 -> blah
|
|
2241 | + rather than
|
|
2242 | + let { d1 = sc_sel1 d; d2 = sc_sel2 d } in blah
|
|
2243 | + The latter works much better with the specialiser: when `d` is instantiated
|
|
2244 | + to some useful dictionary the `sc_sel1 d` selection can fire.
|
|
2245 | + |
|
2246 | + - The attempt to deal with unpacking dictionaries with `case` led to
|
|
2247 | + significant extra complexity in the type-class specialiser (#26158) that is
|
|
2248 | + rendered unnecessary if we only take do superclass selection with superclass
|
|
2249 | + selectors, never with `case` expressions.
|
|
2250 | + |
|
2251 | + Even with that extra complexity, specialisation was /still/ sometimes worse,
|
|
2252 | + and sometimes /tremendously/ worse (a factor of 70x); see #19747.
|
|
2253 | + |
|
2254 | + - Suppose f :: forall a. (% Eq a, Show a %) => blah
|
|
2255 | + The specialiser is perfectly capable of specialising a call like
|
|
2256 | + f @Int (% dEqInt, dShowInt %)
|
|
2257 | + so the tuple doesn't get in the way.
|
|
2258 | + |
|
2259 | + - It's simpler and more uniform. There is nothing special about constraint
|
|
2260 | + tuples; anyone can write class (C1 a, C2 a) => D a where {}
|
|
2251 | 2261 | |
2252 | 2262 | Wrinkle (DNB2): we /do/ want to unbox equality dictionaries,
|
2253 | 2263 | for (~), (~~), and Coercible (#23398). Their payload is a single unboxed
|
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,12 +28,12 @@ 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 | |
... | ... | @@ -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 ( 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 | ************************************************************************
|
... | ... | @@ -1277,67 +1283,10 @@ specCase :: SpecEnv |
1277 | 1283 | , OutId
|
1278 | 1284 | , [OutAlt]
|
1279 | 1285 | , UsageDetails)
|
1280 | -specCase env scrut' case_bndr [Alt con args rhs]
|
|
1281 | - | -- See Note [Floating dictionaries out of cases]
|
|
1282 | - interestingDict scrut' (idType case_bndr)
|
|
1283 | - , not (isDeadBinder case_bndr && null sc_args')
|
|
1284 | - = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
|
|
1285 | - |
|
1286 | - ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
|
|
1287 | - scrut_bind = mkDB (NonRec case_bndr_flt scrut')
|
|
1288 | - |
|
1289 | - sc_args_flt' = zipWith addDictUnfolding sc_args_flt sc_rhss
|
|
1290 | - sc_rhss = [ Case (Var case_bndr_flt') case_bndr' (idType sc_arg')
|
|
1291 | - [Alt con args' (Var sc_arg')]
|
|
1292 | - | sc_arg' <- sc_args' ]
|
|
1293 | - cb_set = unitVarSet case_bndr_flt'
|
|
1294 | - sc_binds = [ DB { db_bind = NonRec sc_arg_flt sc_rhs, db_fvs = cb_set }
|
|
1295 | - | (sc_arg_flt, sc_rhs) <- sc_args_flt' `zip` sc_rhss ]
|
|
1296 | - |
|
1297 | - flt_binds = scrut_bind : sc_binds
|
|
1298 | - |
|
1299 | - -- Extend the substitution for RHS to map the *original* binders
|
|
1300 | - -- to their floated versions.
|
|
1301 | - mb_sc_flts :: [Maybe DictId]
|
|
1302 | - mb_sc_flts = map (lookupVarEnv clone_env) args'
|
|
1303 | - clone_env = zipVarEnv sc_args' sc_args_flt'
|
|
1304 | - |
|
1305 | - subst_prs = (case_bndr, Var case_bndr_flt)
|
|
1306 | - : [ (arg, Var sc_flt)
|
|
1307 | - | (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
|
|
1308 | - subst' = se_subst env_rhs
|
|
1309 | - `Core.extendSubstInScopeList` (case_bndr_flt' : sc_args_flt')
|
|
1310 | - `Core.extendIdSubstList` subst_prs
|
|
1311 | - env_rhs' = env_rhs { se_subst = subst' }
|
|
1312 | - |
|
1313 | - ; (rhs', rhs_uds) <- specExpr env_rhs' rhs
|
|
1314 | - ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr':args') rhs_uds
|
|
1315 | - all_uds = flt_binds `consDictBinds` free_uds
|
|
1316 | - alt' = Alt con args' (wrapDictBindsE dumped_dbs rhs')
|
|
1317 | --- ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
|
|
1318 | - ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
|
|
1319 | - where
|
|
1320 | - (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
|
|
1321 | - sc_args' = filter is_flt_sc_arg args'
|
|
1322 | - |
|
1323 | - clone_me bndr = do { uniq <- getUniqueM
|
|
1324 | - ; return (mkUserLocalOrCoVar occ uniq wght ty loc) }
|
|
1325 | - where
|
|
1326 | - name = idName bndr
|
|
1327 | - wght = idMult bndr
|
|
1328 | - ty = idType bndr
|
|
1329 | - occ = nameOccName name
|
|
1330 | - loc = getSrcSpan name
|
|
1331 | - |
|
1332 | - arg_set = mkVarSet args'
|
|
1333 | - is_flt_sc_arg var = isId var
|
|
1334 | - && not (isDeadBinder var)
|
|
1335 | - && isDictTy var_ty
|
|
1336 | - && tyCoVarsOfType var_ty `disjointVarSet` arg_set
|
|
1337 | - where
|
|
1338 | - var_ty = idType var
|
|
1339 | - |
|
1340 | - |
|
1286 | +-- We used to have a complex special case for
|
|
1287 | +-- case d of { CTuple2 d1 d2 -> blah }
|
|
1288 | +-- but we no longer do so.
|
|
1289 | +-- See Historical Note [Floating dictionaries out of cases]
|
|
1341 | 1290 | specCase env scrut case_bndr alts
|
1342 | 1291 | = do { (alts', uds_alts) <- mapAndCombineSM spec_alt alts
|
1343 | 1292 | ; return (scrut, case_bndr', alts', uds_alts) }
|
... | ... | @@ -1346,14 +1295,11 @@ specCase env scrut case_bndr alts |
1346 | 1295 | spec_alt (Alt con args rhs)
|
1347 | 1296 | = do { (rhs', uds) <- specExpr env_rhs rhs
|
1348 | 1297 | ; let (free_uds, dumped_dbs) = dumpUDs (case_bndr' : args') uds
|
1349 | --- ; unless (isNilOL dumped_dbs) $
|
|
1350 | --- pprTrace "specAlt" (vcat
|
|
1351 | --- [text "case_bndr', args" <+> (ppr case_bndr' $$ ppr args)
|
|
1352 | --- ,text "dumped" <+> ppr dumped_dbs ]) return ()
|
|
1353 | 1298 | ; return (Alt con args' (wrapDictBindsE dumped_dbs rhs'), free_uds) }
|
1354 | 1299 | where
|
1355 | 1300 | (env_rhs, args') = substBndrs env_alt args
|
1356 | 1301 | |
1302 | + |
|
1357 | 1303 | {- Note [Fire rules in the specialiser]
|
1358 | 1304 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
1359 | 1305 | Consider this (#21851)
|
... | ... | @@ -1414,36 +1360,39 @@ Note [tryRules: plan (BEFORE)] in the Simplifier (partly) redundant. That is, |
1414 | 1360 | if we run rules in the specialiser, does it matter if we make rules "win" over
|
1415 | 1361 | inlining in the Simplifier? Yes, it does! See the discussion in #21851.
|
1416 | 1362 | |
1417 | -Note [Floating dictionaries out of cases]
|
|
1418 | -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
1419 | -Consider
|
|
1363 | +Historical Note [Floating dictionaries out of cases]
|
|
1364 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
1365 | +Function `specCase` used to give special treatment to a case-expression
|
|
1366 | +that scrutinised a dictionary, like this:
|
|
1420 | 1367 | g = \d. case d of { MkD sc ... -> ...(f sc)... }
|
1421 | -Naively we can't float d2's binding out of the case expression,
|
|
1422 | -because 'sc' is bound by the case, and that in turn means we can't
|
|
1423 | -specialise f, which seems a pity.
|
|
1424 | - |
|
1425 | -So we invert the case, by floating out a binding
|
|
1426 | -for 'sc_flt' thus:
|
|
1427 | - sc_flt = case d of { MkD sc ... -> sc }
|
|
1428 | -Now we can float the call instance for 'f'. Indeed this is just
|
|
1429 | -what'll happen if 'sc' was originally bound with a let binding,
|
|
1430 | -but case is more efficient, and necessary with equalities. So it's
|
|
1431 | -good to work with both.
|
|
1432 | - |
|
1433 | -You might think that this won't make any difference, because the
|
|
1434 | -call instance will only get nuked by the \d. BUT if 'g' itself is
|
|
1435 | -specialised, then transitively we should be able to specialise f.
|
|
1436 | - |
|
1437 | -In general, given
|
|
1438 | - case e of cb { MkD sc ... -> ...(f sc)... }
|
|
1439 | -we transform to
|
|
1440 | - let cb_flt = e
|
|
1441 | - sc_flt = case cb_flt of { MkD sc ... -> sc }
|
|
1442 | - in
|
|
1443 | - case cb_flt of bg { MkD sc ... -> ....(f sc_flt)... }
|
|
1444 | - |
|
1445 | -The "_flt" things are the floated binds; we use the current substitution
|
|
1446 | -to substitute sc -> sc_flt in the RHS
|
|
1368 | +But actually
|
|
1369 | + |
|
1370 | +* We never explicitly case-analyse a dictionary; rather the class-op
|
|
1371 | + rules select superclasses from it. NB: in the past worker/wrapper
|
|
1372 | + unboxed tuple dictionaries, but no longer; see (DNB1) in
|
|
1373 | + Note [Do not unbox class dictionaries] in GHC.Core.Opt.DmdAnal.
|
|
1374 | + Now it really is the case that only the class-op and superclass
|
|
1375 | + selectors take dictionaries apart.
|
|
1376 | + |
|
1377 | +* Calling `interestingDict` on every scrutinee is hardly sensible;
|
|
1378 | + generally `interestingDict` is called only on Constraint-kinded things.
|
|
1379 | + |
|
1380 | +* It was giving a Lint scope error in !14272
|
|
1381 | + |
|
1382 | +So now there is no special case. This Note just records the change
|
|
1383 | +in case we ever want to reinstate it. The original note was
|
|
1384 | +added in
|
|
1385 | + |
|
1386 | + commit c107a00ccf1e641a2d008939cf477c71caa028d5
|
|
1387 | + Author: Simon Peyton Jones <simonpj@microsoft.com>
|
|
1388 | + Date: Thu Aug 12 13:11:33 2010 +0000
|
|
1389 | + |
|
1390 | + Improve the Specialiser, fixing Trac #4203
|
|
1391 | + |
|
1392 | +The ticket to remove the code is #26158.
|
|
1393 | + |
|
1394 | +End of Historical Note
|
|
1395 | + |
|
1447 | 1396 | |
1448 | 1397 | ************************************************************************
|
1449 | 1398 | * *
|
... | ... | @@ -1644,9 +1593,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
1644 | 1593 | -- switch off specialisation for inline functions
|
1645 | 1594 | |
1646 | 1595 | = -- pprTrace "specCalls: some" (vcat
|
1647 | - -- [ text "function" <+> ppr fn
|
|
1648 | - -- , text "calls:" <+> ppr calls_for_me
|
|
1649 | - -- , text "subst" <+> ppr (se_subst env) ]) $
|
|
1596 | + -- [ text "function" <+> ppr fn
|
|
1597 | + -- , text "calls:" <+> ppr calls_for_me
|
|
1598 | + -- , text "subst" <+> ppr (se_subst env) ]) $
|
|
1650 | 1599 | foldlM spec_call ([], [], emptyUDs) calls_for_me
|
1651 | 1600 | |
1652 | 1601 | | otherwise -- No calls or RHS doesn't fit our preconceptions
|
... | ... | @@ -1694,21 +1643,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs |
1694 | 1643 | , rule_bndrs, rule_lhs_args
|
1695 | 1644 | , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
|
1696 | 1645 | |
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 ()
|
|
1646 | + ; when False $ pprTrace "spec_call" (vcat
|
|
1647 | + [ text "fun: " <+> ppr fn
|
|
1648 | + , text "call info: " <+> ppr _ci
|
|
1649 | + , text "useful: " <+> ppr useful
|
|
1650 | + , text "rule_bndrs:" <+> ppr rule_bndrs
|
|
1651 | + , text "lhs_args: " <+> ppr rule_lhs_args
|
|
1652 | + , text "spec_bndrs1:" <+> ppr spec_bndrs1
|
|
1653 | + , text "leftover_bndrs:" <+> pprIds leftover_bndrs
|
|
1654 | + , text "spec_args: " <+> ppr spec_args
|
|
1655 | + , text "dx_binds: " <+> ppr dx_binds
|
|
1656 | + , text "rhs_bndrs" <+> ppr rhs_bndrs
|
|
1657 | + , text "rhs_body" <+> ppr rhs_body
|
|
1658 | + , text "rhs_env2: " <+> ppr (se_subst rhs_env2)
|
|
1659 | + , ppr dx_binds ]) $
|
|
1660 | + return ()
|
|
1712 | 1661 | |
1713 | 1662 | ; let all_rules = rules_acc ++ existing_rules
|
1714 | 1663 | -- all_rules: we look both in the rules_acc (generated by this invocation
|
... | ... | @@ -3102,30 +3051,14 @@ mkCallUDs' env f args |
3102 | 3051 | -- For "invisibleFunArg", which are the type-class dictionaries,
|
3103 | 3052 | -- we decide on a case by case basis if we want to specialise
|
3104 | 3053 | -- on this argument; if so, SpecDict, if not UnspecArg
|
3105 | - mk_spec_arg arg (Anon pred af)
|
|
3054 | + mk_spec_arg arg (Anon _pred af)
|
|
3106 | 3055 | | isInvisibleFunArg af
|
3107 | - , interestingDict arg (scaledThing pred)
|
|
3056 | + , interestingDict env arg
|
|
3108 | 3057 | -- See Note [Interesting dictionary arguments]
|
3109 | 3058 | = SpecDict arg
|
3110 | 3059 | |
3111 | 3060 | | otherwise = UnspecArg
|
3112 | 3061 | |
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 | 3062 | wantCallsFor :: SpecEnv -> Id -> Bool
|
3130 | 3063 | -- See Note [wantCallsFor]
|
3131 | 3064 | wantCallsFor _env f
|
... | ... | @@ -3145,8 +3078,60 @@ wantCallsFor _env f |
3145 | 3078 | WorkerLikeId {} -> True
|
3146 | 3079 | RepPolyId {} -> True
|
3147 | 3080 | |
3148 | -{- Note [wantCallsFor]
|
|
3149 | -~~~~~~~~~~~~~~~~~~~~~~
|
|
3081 | +interestingDict :: SpecEnv -> CoreExpr -> Bool
|
|
3082 | +-- This is a subtle and important function
|
|
3083 | +-- See Note [Interesting dictionary arguments]
|
|
3084 | +interestingDict env (Var v) -- See (ID3) and (ID5)
|
|
3085 | + | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)
|
|
3086 | + -- Might fail for loop breaker dicts but that seems fine.
|
|
3087 | + = interestingDict env rhs
|
|
3088 | + |
|
3089 | +interestingDict env arg -- Main Plan: use exprIsConApp_maybe
|
|
3090 | + | Cast inner_arg _ <- arg -- See (ID5)
|
|
3091 | + = if | isConstraintKind $ typeKind $ exprType inner_arg
|
|
3092 | + -- If coercions were always homo-kinded, we'd know
|
|
3093 | + -- that this would be the only case
|
|
3094 | + -> interestingDict env inner_arg
|
|
3095 | + |
|
3096 | + -- Check for an implicit parameter at the top
|
|
3097 | + | Just (cls,_) <- getClassPredTys_maybe arg_ty
|
|
3098 | + , isIPClass cls -- See (ID4)
|
|
3099 | + -> False
|
|
3100 | + |
|
3101 | + -- Otherwise we are unwrapping a unary type class
|
|
3102 | + | otherwise
|
|
3103 | + -> exprIsHNF arg -- See (ID7)
|
|
3104 | + |
|
3105 | + | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg
|
|
3106 | + , Just cls <- tyConClass_maybe (dataConTyCon data_con)
|
|
3107 | + , not_ip_like -- See (ID4)
|
|
3108 | + = if null (classMethods cls) -- See (ID6)
|
|
3109 | + then any (interestingDict env) args
|
|
3110 | + else True
|
|
3111 | + |
|
3112 | + | otherwise
|
|
3113 | + = not (exprIsTrivial arg) && not_ip_like -- See (ID8)
|
|
3114 | + where
|
|
3115 | + arg_ty = exprType arg
|
|
3116 | + not_ip_like = not (couldBeIPLike arg_ty)
|
|
3117 | + in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding
|
|
3118 | + |
|
3119 | +{- Note [Ticks on applications]
|
|
3120 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
3121 | +Ticks such as source location annotations can sometimes make their way
|
|
3122 | +onto applications (see e.g. #21697). So if we see something like
|
|
3123 | + |
|
3124 | + App (Tick _ f) e
|
|
3125 | + |
|
3126 | +we need to descend below the tick to find what the real function being
|
|
3127 | +applied is.
|
|
3128 | + |
|
3129 | +The resulting RULE also has to be able to match this annotated use
|
|
3130 | +site, so we only look through ticks that RULE matching looks through
|
|
3131 | +(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
|
|
3132 | + |
|
3133 | +Note [wantCallsFor]
|
|
3134 | +~~~~~~~~~~~~~~~~~~~
|
|
3150 | 3135 | `wantCallsFor env f` says whether the Specialiser should collect calls for
|
3151 | 3136 | function `f`; other thing being equal, the fewer calls we collect the better. It
|
3152 | 3137 | is False for things we can't specialise:
|
... | ... | @@ -3172,44 +3157,91 @@ collect usage info for imported overloaded functions. |
3172 | 3157 | |
3173 | 3158 | Note [Interesting dictionary arguments]
|
3174 | 3159 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
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.
|
|
3160 | +Consider this
|
|
3161 | + \a.\d:Eq a. let f = ... in ...(f d)...
|
|
3162 | +There really is not much point in specialising f wrt the dictionary d,
|
|
3163 | +because the code for the specialised f is not improved at all, because
|
|
3164 | +d is lambda-bound. We simply get junk specialisations.
|
|
3165 | + |
|
3166 | +What is "interesting"? Our Main Plan is to use `exprIsConApp_maybe` to see
|
|
3167 | +if the argument is a dictionary constructor applied to some arguments, in which
|
|
3168 | +case we can clearly specialise. But there are wrinkles:
|
|
3169 | + |
|
3170 | +(ID1) Note that we look at the argument /term/, not its /type/. Suppose the
|
|
3171 | + argument is
|
|
3172 | + (% d1, d2 %) |> co
|
|
3173 | + where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.
|
|
3174 | + Then its type (F Int a) looks very un-informative, but the term is super
|
|
3175 | + helpful. See #19747 (where missing this point caused a 70x slow down)
|
|
3176 | + and #7785.
|
|
3177 | + |
|
3178 | +(ID2) Note that the Main Plan works fine for an argument that is a DFun call,
|
|
3179 | + e.g. $fOrdList $dOrdInt
|
|
3180 | + because `exprIsConApp_maybe` cleverly deals with DFunId applications. Good!
|
|
3181 | + |
|
3182 | +(ID3) For variables, we look in the variable's /unfolding/. And that means
|
|
3183 | + that we must be careful to ensure that dictionaries /have/ unfoldings:
|
|
3184 | + * cloneBndrSM discards non-Stable unfoldings
|
|
3185 | + * specBind updates the unfolding after specialisation
|
|
3186 | + See Note [Update unfolding after specialisation]
|
|
3187 | + * bindAuxiliaryDict adds an unfolding for an aux dict
|
|
3188 | + see Note [Specialisation modulo dictionary selectors]
|
|
3189 | + * specCase adds unfoldings for the new bindings it creates
|
|
3190 | + |
|
3191 | + We accidentally lost accurate tracking of local variables for a long
|
|
3192 | + time, because cloned variables didn't have unfoldings. But makes a
|
|
3193 | + massive difference in a few cases, eg #5113. For nofib as a
|
|
3194 | + whole it's only a small win: 2.2% improvement in allocation for ansi,
|
|
3195 | + 1.2% for bspt, but mostly 0.0! Average 0.1% increase in binary size.
|
|
3196 | + |
|
3197 | +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains
|
|
3198 | + an implicit parameter, because implicit parameters are emphatically not singleton
|
|
3199 | + types. See #25999:
|
|
3200 | + useImplicit :: (?i :: Int) => Int
|
|
3201 | + useImplicit = ?i + 1
|
|
3202 | + |
|
3203 | + foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)
|
|
3204 | + Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.
|
|
3205 | + We must not specialise on implicit parameters! Hence the call to `couldBeIPLike`.
|
|
3206 | + |
|
3207 | +(ID5) Suppose the argument is (e |> co). Can we rely on `exprIsConApp_maybe` to deal
|
|
3208 | + with the coercion. No! That only works if (co :: C t1 ~ C t2) with the same type
|
|
3209 | + constructor at the top of both sides. But see the example in (ID1), where that
|
|
3210 | + is not true. For thes same reason, we can't rely on `exprIsConApp_maybe` to look
|
|
3211 | + through unfoldings (because there might be a cast inside), hence dealing with
|
|
3212 | + expandable unfoldings in `interestingDict` directly.
|
|
3213 | + |
|
3214 | +(ID6) The Main Plan says that it's worth specialising if the argument is an application
|
|
3215 | + of a dictionary contructor. But what if the dictionary has no methods? Then we
|
|
3216 | + gain nothing by specialising, unless the /superclasses/ are interesting. A case
|
|
3217 | + in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class
|
|
3218 | + with N superclasses and no methods.
|
|
3219 | + |
|
3220 | +(ID7) A unary (single-method) class is currently represented by (meth |> co). We
|
|
3221 | + will unwrap the cast (see (ID5)) and then want to reply "yes" if the method
|
|
3222 | + has any struture. We rather arbitrarily use `exprIsHNF` for this. (We plan a
|
|
3223 | + new story for unary classes, see #23109, and this special case will become
|
|
3224 | + irrelevant.)
|
|
3225 | + |
|
3226 | +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a
|
|
3227 | + non-trivial argument as interesting. In T19695 we have this:
|
|
3228 | + askParams :: Monad m => blah
|
|
3229 | + mhelper :: MonadIO m => blah
|
|
3230 | + mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....
|
|
3231 | + where `$p1` is the superclass selector for `MonadIO`. Now, if `mhelper` is
|
|
3232 | + specialised at `Handler` we'll get this call in the specialised `$smhelper`:
|
|
3233 | + askParams @Handler ($p1 $fMonadIOHandler)
|
|
3234 | + and we /definitely/ want to specialise that, even though the argument isn't
|
|
3235 | + visibly a dictionary application. In fact the specialiser fires the superclass
|
|
3236 | + selector rule (see Note [Fire rules in the specialiser]), so we get
|
|
3237 | + askParams @Handler ($cp1MonadIO $fMonadIOIO)
|
|
3238 | + but it /still/ doesn't look like a dictionary application.
|
|
3239 | + |
|
3240 | + Conclusion: we optimistically assume that any non-trivial argument is worth
|
|
3241 | + specialising on.
|
|
3242 | + |
|
3243 | + So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look
|
|
3244 | + under type-family casts (ID1) and constraint tuples (ID6).
|
|
3213 | 3245 | |
3214 | 3246 | Note [Update unfolding after specialisation]
|
3215 | 3247 | ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
... | ... | @@ -3237,6 +3269,7 @@ Consider (#21848) |
3237 | 3269 | Now `f` turns into:
|
3238 | 3270 | |
3239 | 3271 | f @a @b (dd :: D a) (ds :: Show b) a b
|
3272 | + |
|
3240 | 3273 | = let dc :: D a = %p1 dd -- Superclass selection
|
3241 | 3274 | in meth @a dc ....
|
3242 | 3275 | meth @a dc ....
|
... | ... | @@ -3252,27 +3285,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with |
3252 | 3285 | the Rec case.)
|
3253 | 3286 | -}
|
3254 | 3287 | |
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 | 3288 | thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
|
3277 | 3289 | thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
|
3278 | 3290 | (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,
|
... | ... | @@ -126,9 +126,12 @@ isDictTy ty = isClassPred pred |
126 | 126 | where
|
127 | 127 | (_, pred) = splitInvisPiTys ty
|
128 | 128 | |
129 | +-- | Is the type *guaranteed* to determine the value?
|
|
130 | +--
|
|
131 | +-- Might say No even if the type does determine the value. (See the Note)
|
|
129 | 132 | typeDeterminesValue :: Type -> Bool
|
130 | 133 | -- See Note [Type determines value]
|
131 | -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
|
|
134 | +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)
|
|
132 | 135 | |
133 | 136 | getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
|
134 | 137 | getClassPredTys ty = case getClassPredTys_maybe ty of
|
... | ... | @@ -171,6 +174,10 @@ So we treat implicit params just like ordinary arguments for the |
171 | 174 | purposes of specialisation. Note that we still want to specialise
|
172 | 175 | functions with implicit params if they have *other* dicts which are
|
173 | 176 | class params; see #17930.
|
177 | + |
|
178 | +It's also not always possible to infer that a type determines the value
|
|
179 | +if type families are in play. See #19747 for one such example.
|
|
180 | + |
|
174 | 181 | -}
|
175 | 182 | |
176 | 183 | -- --------------------- Equality predicates ---------------------------------
|
... | ... | @@ -421,44 +428,44 @@ isCallStackTy ty |
421 | 428 | | otherwise
|
422 | 429 | = False
|
423 | 430 | |
424 | --- --------------------- isIPLike and mentionsIP --------------------------
|
|
431 | +-- --------------------- couldBeIPLike and mightMentionIP --------------------------
|
|
425 | 432 | -- See Note [Local implicit parameters]
|
426 | 433 | |
427 | -isIPLikePred :: Type -> Bool
|
|
434 | +couldBeIPLike :: Type -> Bool
|
|
428 | 435 | -- Is `pred`, or any of its superclasses, an implicit parameter?
|
429 | 436 | -- See Note [Local implicit parameters]
|
430 | -isIPLikePred pred =
|
|
431 | - mentions_ip_pred initIPRecTc (const True) (const True) pred
|
|
432 | - |
|
433 | -mentionsIP :: (Type -> Bool) -- ^ predicate on the string
|
|
434 | - -> (Type -> Bool) -- ^ predicate on the type
|
|
435 | - -> Class
|
|
436 | - -> [Type] -> Bool
|
|
437 | --- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
|
|
437 | +couldBeIPLike pred
|
|
438 | + = might_mention_ip1 initIPRecTc (const True) (const True) pred
|
|
439 | + |
|
440 | +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string
|
|
441 | + -> (Type -> Bool) -- ^ predicate on the type
|
|
442 | + -> Class
|
|
443 | + -> [Type] -> Bool
|
|
444 | +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:
|
|
438 | 445 | --
|
439 | 446 | -- - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
|
440 | 447 | -- are both @True@,
|
441 | 448 | -- - or any superclass of @cls tys@ has this property.
|
442 | 449 | --
|
443 | 450 | -- See Note [Local implicit parameters]
|
444 | -mentionsIP = mentions_ip initIPRecTc
|
|
451 | +mightMentionIP = might_mention_ip initIPRecTc
|
|
445 | 452 | |
446 | -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
|
|
447 | -mentions_ip rec_clss str_cond ty_cond cls tys
|
|
453 | +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
|
|
454 | +might_mention_ip rec_clss str_cond ty_cond cls tys
|
|
448 | 455 | | Just (str_ty, ty) <- isIPPred_maybe cls tys
|
449 | 456 | = str_cond str_ty && ty_cond ty
|
450 | 457 | | otherwise
|
451 | - = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
|
|
458 | + = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
|
|
452 | 459 | | sc_sel_id <- classSCSelIds cls ]
|
453 | 460 | |
454 | 461 | |
455 | -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
|
|
456 | -mentions_ip_pred rec_clss str_cond ty_cond ty
|
|
462 | +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
|
|
463 | +might_mention_ip1 rec_clss str_cond ty_cond ty
|
|
457 | 464 | | Just (cls, tys) <- getClassPredTys_maybe ty
|
458 | 465 | , let tc = classTyCon cls
|
459 | 466 | , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
|
460 | 467 | else checkRecTc rec_clss tc
|
461 | - = mentions_ip rec_clss' str_cond ty_cond cls tys
|
|
468 | + = might_mention_ip rec_clss' str_cond ty_cond cls tys
|
|
462 | 469 | | otherwise
|
463 | 470 | = False -- Includes things like (D []) where D is
|
464 | 471 | -- a Constraint-ranged family; #7785
|
... | ... | @@ -471,7 +478,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc |
471 | 478 | See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in
|
472 | 479 | GHC.Tc.Solver.Dict.
|
473 | 480 | |
474 | -The function isIPLikePred tells if this predicate, or any of its
|
|
481 | +The function couldBeIPLike tells if this predicate, or any of its
|
|
475 | 482 | superclasses, is an implicit parameter.
|
476 | 483 | |
477 | 484 | Why are implicit parameters special? Unlike normal classes, we can
|
... | ... | @@ -479,7 +486,7 @@ have local instances for implicit parameters, in the form of |
479 | 486 | let ?x = True in ...
|
480 | 487 | So in various places we must be careful not to assume that any value
|
481 | 488 | of the right type will do; we must carefully look for the innermost binding.
|
482 | -So isIPLikePred checks whether this is an implicit parameter, or has
|
|
489 | +So couldBeIPLike checks whether this is an implicit parameter, or has
|
|
483 | 490 | a superclass that is an implicit parameter.
|
484 | 491 | |
485 | 492 | Several wrinkles
|
... | ... | @@ -520,16 +527,16 @@ Small worries (Sept 20): |
520 | 527 | think nothing does.
|
521 | 528 | * I'm a little concerned about type variables; such a variable might
|
522 | 529 | be instantiated to an implicit parameter. I don't think this
|
523 | - matters in the cases for which isIPLikePred is used, and it's pretty
|
|
530 | + matters in the cases for which couldBeIPLike is used, and it's pretty
|
|
524 | 531 | obscure anyway.
|
525 | 532 | * The superclass hunt stops when it encounters the same class again,
|
526 | 533 | but in principle we could have the same class, differently instantiated,
|
527 | 534 | and the second time it could have an implicit parameter
|
528 | 535 | I'm going to treat these as problems for another day. They are all exotic.
|
529 | 536 | |
530 | -Note [Using typesAreApart when calling mentionsIP]
|
|
531 | -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
532 | -We call 'mentionsIP' in two situations:
|
|
537 | +Note [Using typesAreApart when calling mightMentionIP]
|
|
538 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
539 | +We call 'mightMentionIP' in two situations:
|
|
533 | 540 | |
534 | 541 | (1) to check that a predicate does not contain any implicit parameters
|
535 | 542 | IP str ty, for a fixed literal str and any type ty,
|
... | ... | @@ -1914,7 +1914,7 @@ growThetaTyVars theta tcvs |
1914 | 1914 | | otherwise = transCloVarSet mk_next seed_tcvs
|
1915 | 1915 | where
|
1916 | 1916 | seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
|
1917 | - (ips, non_ips) = partition isIPLikePred theta
|
|
1917 | + (ips, non_ips) = partition couldBeIPLike theta
|
|
1918 | 1918 | -- See Note [Inheriting implicit parameters]
|
1919 | 1919 | |
1920 | 1920 | 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
|
... | ... | @@ -2040,10 +2040,10 @@ solveOneFromTheOther ct_i ct_w |
2040 | 2040 | is_wsc_orig_w = isWantedSuperclassOrigin orig_w
|
2041 | 2041 | |
2042 | 2042 | different_level_strategy -- Both Given
|
2043 | - | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
|
|
2044 | - | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
|
|
2043 | + | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork else KeepInert
|
|
2044 | + | otherwise = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
|
|
2045 | 2045 | -- See Note [Replacement vs keeping] part (1)
|
2046 | - -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
|
|
2046 | + -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]
|
|
2047 | 2047 | -- in GHC.Tc.Solver.Dict
|
2048 | 2048 | |
2049 | 2049 | same_level_strategy -- Both Given
|
... | ... | @@ -401,8 +401,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys }) |
401 | 401 | -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
|
402 | 402 | does_not_mention_ip_for :: Type -> DictCt -> Bool
|
403 | 403 | does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
|
404 | - = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
|
|
405 | - -- See Note [Using typesAreApart when calling mentionsIP]
|
|
404 | + = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
|
|
405 | + -- See Note [Using typesAreApart when calling mightMentionIP]
|
|
406 | 406 | -- in GHC.Core.Predicate
|
407 | 407 | |
408 | 408 | updInertIrreds :: IrredCt -> TcS ()
|
... | ... | @@ -534,7 +534,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) |
534 | 534 | = do { is_callstack <- is_tyConTy isCallStackTy callStackTyConName
|
535 | 535 | ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
|
536 | 536 | ; let contains_callstack_or_exceptionCtx =
|
537 | - mentionsIP
|
|
537 | + mightMentionIP
|
|
538 | 538 | (const True)
|
539 | 539 | -- NB: the name of the call-stack IP is irrelevant
|
540 | 540 | -- e.g (?foo :: CallStack) counts!
|
... | ... | @@ -552,9 +552,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev }) |
552 | 552 | |
553 | 553 | -- Return a predicate that decides whether a type is CallStack
|
554 | 554 | -- or ExceptionContext, accounting for e.g. type family reduction, as
|
555 | - -- per Note [Using typesAreApart when calling mentionsIP].
|
|
555 | + -- per Note [Using typesAreApart when calling mightMentionIP].
|
|
556 | 556 | --
|
557 | - -- See Note [Using isCallStackTy in mentionsIP].
|
|
557 | + -- See Note [Using isCallStackTy in mightMentionIP].
|
|
558 | 558 | is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
|
559 | 559 | is_tyConTy is_eq tc_name
|
560 | 560 | = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name
|
... | ... | @@ -582,14 +582,14 @@ in a different context! |
582 | 582 | See also Note [Shadowing of implicit parameters], which deals with a similar
|
583 | 583 | problem with Given implicit parameter constraints.
|
584 | 584 | |
585 | -Note [Using isCallStackTy in mentionsIP]
|
|
586 | -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
585 | +Note [Using isCallStackTy in mightMentionIP]
|
|
586 | +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
587 | 587 | To implement Note [Don't add HasCallStack constraints to the solved set],
|
588 | 588 | we need to check whether a constraint contains a HasCallStack or HasExceptionContext
|
589 | 589 | constraint. We do this using the 'mentionsIP' function, but as per
|
590 | -Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
|
|
590 | +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:
|
|
591 | 591 | |
592 | - mentionsIP
|
|
592 | + mightMentionIP
|
|
593 | 593 | (const True) -- (ignore the implicit parameter string)
|
594 | 594 | (isCallStackTy <||> isExceptionContextTy)
|
595 | 595 |
... | ... | @@ -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 T26051(main, foo) where
|
|
5 | + |
|
6 | +import T26051_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 T26051_Import ( T26051_Import.hs, T26051_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 (T26051_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 (T26051_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 (T26051_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 (T26051_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 T26051 ( T26051.hs, T26051.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 T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_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 T26051_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (T26051_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 (T26051_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.StdHandles.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/T26051 $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). T26051_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe
|
|
76 | +"SPEC/T26051 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 T26051_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('T26051', [ grep_errmsg(r'\$wspecMe')
|
|
553 | + , extra_files(['T26051_Import.hs'])
|
|
554 | + , only_ways(['optasm'])],
|
|
555 | + multimod_compile,
|
|
556 | + ['T26051', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000']) |