Simon Peyton Jones pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC

Commits:

16 changed files:

Changes:

  • compiler/GHC/Core/Opt/DmdAnal.hs
    ... ... @@ -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
    

  • compiler/GHC/Core/Opt/Specialise.hs
    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})
    

  • compiler/GHC/Core/Predicate.hs
    ... ... @@ -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,
    

  • compiler/GHC/Tc/Solver.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Solver/Dict.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Solver/InertSet.hs
    ... ... @@ -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
    

  • compiler/GHC/Tc/Solver/Monad.hs
    ... ... @@ -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
     
    

  • compiler/GHC/Tc/Utils/TcType.hs
    ... ... @@ -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
    

  • testsuite/tests/perf/should_run/SpecTyFamRun.hs
    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]

  • testsuite/tests/perf/should_run/SpecTyFamRun.stdout
    1
    +500500

  • testsuite/tests/perf/should_run/SpecTyFam_Import.hs
    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)

  • testsuite/tests/perf/should_run/all.T
    ... ... @@ -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'])

  • testsuite/tests/simplCore/should_compile/T26051.hs
    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]

  • testsuite/tests/simplCore/should_compile/T26051.stderr
    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
    +

  • testsuite/tests/simplCore/should_compile/T26051_Import.hs
    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)

  • testsuite/tests/simplCore/should_compile/all.T
    ... ... @@ -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'])