Andreas Klebinger pushed to branch wip/andreask/spec_tyfams at Glasgow Haskell Compiler / GHC

Commits:

15 changed files:

Changes:

  • 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,16 +28,16 @@ import GHC.Core.Make ( mkLitRubbish )
    26 28
     import GHC.Core.Unify     ( tcMatchTy )
    
    27 29
     import GHC.Core.Rules
    
    28 30
     import GHC.Core.Utils     ( exprIsTrivial, exprIsTopLevelBindable
    
    29
    -                          , mkCast, exprType
    
    31
    +                          , mkCast, exprType, exprIsHNF
    
    30 32
                               , stripTicksTop, mkInScopeSetBndrs )
    
    31 33
     import GHC.Core.FVs
    
    32 34
     import GHC.Core.TyCo.FVs ( tyCoVarsOfTypeList )
    
    33 35
     import GHC.Core.Opt.Arity( collectBindersPushingCo )
    
    34
    --- import GHC.Core.Ppr( pprIds )
    
    36
    +import GHC.Core.Ppr( pprIds )
    
    35 37
     
    
    36 38
     import GHC.Builtin.Types  ( unboxedUnitTy )
    
    37 39
     
    
    38
    -import GHC.Data.Maybe     ( maybeToList, isJust )
    
    40
    +import GHC.Data.Maybe     ( maybeToList, isJust, expectJust )
    
    39 41
     import GHC.Data.Bag
    
    40 42
     import GHC.Data.OrdList
    
    41 43
     import GHC.Data.List.SetOps
    
    ... ... @@ -64,8 +66,12 @@ import GHC.Unit.Module.ModGuts
    64 66
     import GHC.Core.Unfold
    
    65 67
     
    
    66 68
     import Data.List( partition )
    
    67
    -import Data.List.NonEmpty ( NonEmpty (..) )
    
    69
    +import Data.List.NonEmpty as NE( nonEmpty, NonEmpty(..) )
    
    68 70
     import GHC.Core.Subst (substTickish)
    
    71
    +import GHC.Core.TyCon (tyConClass_maybe)
    
    72
    +import GHC.Core.DataCon (dataConTyCon)
    
    73
    +
    
    74
    +import Control.Monad
    
    69 75
     
    
    70 76
     {-
    
    71 77
     ************************************************************************
    
    ... ... @@ -1279,9 +1285,9 @@ specCase :: SpecEnv
    1279 1285
                       , UsageDetails)
    
    1280 1286
     specCase env scrut' case_bndr [Alt con args rhs]
    
    1281 1287
       | -- See Note [Floating dictionaries out of cases]
    
    1282
    -    interestingDict scrut' (idType case_bndr)
    
    1288
    +    interestingDict env scrut'
    
    1283 1289
       , not (isDeadBinder case_bndr && null sc_args')
    
    1284
    -  = do { case_bndr_flt :| sc_args_flt <- mapM clone_me (case_bndr' :| sc_args')
    
    1290
    +  = do { case_bndr_flt : sc_args_flt <- mapM clone_me (case_bndr' : sc_args')
    
    1285 1291
     
    
    1286 1292
            ; let case_bndr_flt' = case_bndr_flt `addDictUnfolding` scrut'
    
    1287 1293
                  scrut_bind     = mkDB (NonRec case_bndr_flt scrut')
    
    ... ... @@ -1317,7 +1323,8 @@ specCase env scrut' case_bndr [Alt con args rhs]
    1317 1323
     --       ; pprTrace "specCase" (ppr case_bndr $$ ppr scrut_bind) $
    
    1318 1324
            ; return (Var case_bndr_flt, case_bndr', [alt'], all_uds) }
    
    1319 1325
       where
    
    1320
    -    (env_rhs, (case_bndr':|args')) = substBndrs env (case_bndr:|args)
    
    1326
    +    (env_rhs, bndrs'::[CoreBndr]) = substBndrs env (case_bndr:args)
    
    1327
    +    (case_bndr':|args') = expectJust (NE.nonEmpty bndrs' :: Maybe (NonEmpty CoreBndr))
    
    1321 1328
         sc_args' = filter is_flt_sc_arg args'
    
    1322 1329
     
    
    1323 1330
         clone_me bndr = do { uniq <- getUniqueM
    
    ... ... @@ -1332,7 +1339,6 @@ specCase env scrut' case_bndr [Alt con args rhs]
    1332 1339
         arg_set = mkVarSet args'
    
    1333 1340
         is_flt_sc_arg var =  isId var
    
    1334 1341
                           && not (isDeadBinder var)
    
    1335
    -                      && isDictTy var_ty
    
    1336 1342
                           && tyCoVarsOfType var_ty `disjointVarSet` arg_set
    
    1337 1343
            where
    
    1338 1344
              var_ty = idType var
    
    ... ... @@ -1644,9 +1650,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
    1644 1650
     --      switch off specialisation for inline functions
    
    1645 1651
     
    
    1646 1652
       = -- pprTrace "specCalls: some" (vcat
    
    1647
    -    --   [ text "function" <+> ppr fn
    
    1648
    -    --    , text "calls:" <+> ppr calls_for_me
    
    1649
    -    --    , text "subst" <+> ppr (se_subst env) ]) $
    
    1653
    +    --  [ text "function" <+> ppr fn
    
    1654
    +    --  , text "calls:" <+> ppr calls_for_me
    
    1655
    +    --  , text "subst" <+> ppr (se_subst env) ]) $
    
    1650 1656
         foldlM spec_call ([], [], emptyUDs) calls_for_me
    
    1651 1657
     
    
    1652 1658
       | otherwise   -- No calls or RHS doesn't fit our preconceptions
    
    ... ... @@ -1694,21 +1700,21 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
    1694 1700
                  , rule_bndrs, rule_lhs_args
    
    1695 1701
                  , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
    
    1696 1702
     
    
    1697
    ---           ; pprTrace "spec_call" (vcat
    
    1698
    ---                [ text "fun:       "  <+> ppr fn
    
    1699
    ---                , text "call info: "  <+> ppr _ci
    
    1700
    ---                , text "useful:    "  <+> ppr useful
    
    1701
    ---                , text "rule_bndrs:"  <+> ppr rule_bndrs
    
    1702
    ---                , text "lhs_args:  "  <+> ppr rule_lhs_args
    
    1703
    ---                , text "spec_bndrs1:" <+> ppr spec_bndrs1
    
    1704
    ---                , text "leftover_bndrs:" <+> pprIds leftover_bndrs
    
    1705
    ---                , text "spec_args: "  <+> ppr spec_args
    
    1706
    ---                , text "dx_binds:  "  <+> ppr dx_binds
    
    1707
    ---                , text "rhs_bndrs"     <+> ppr rhs_bndrs
    
    1708
    ---                , text "rhs_body"     <+> ppr rhs_body
    
    1709
    ---                , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)
    
    1710
    ---                , ppr dx_binds ]) $
    
    1711
    ---             return ()
    
    1703
    +          ; when False $ pprTrace "spec_call" (vcat
    
    1704
    +               [ text "fun:       "  <+> ppr fn
    
    1705
    +               , text "call info: "  <+> ppr _ci
    
    1706
    +               , text "useful:    "  <+> ppr useful
    
    1707
    +               , text "rule_bndrs:"  <+> ppr rule_bndrs
    
    1708
    +               , text "lhs_args:  "  <+> ppr rule_lhs_args
    
    1709
    +               , text "spec_bndrs1:" <+> ppr spec_bndrs1
    
    1710
    +               , text "leftover_bndrs:" <+> pprIds leftover_bndrs
    
    1711
    +               , text "spec_args: "  <+> ppr spec_args
    
    1712
    +               , text "dx_binds:  "  <+> ppr dx_binds
    
    1713
    +               , text "rhs_bndrs"     <+> ppr rhs_bndrs
    
    1714
    +               , text "rhs_body"     <+> ppr rhs_body
    
    1715
    +               , text "rhs_env2:  "  <+> ppr (se_subst rhs_env2)
    
    1716
    +               , ppr dx_binds ]) $
    
    1717
    +            return ()
    
    1712 1718
     
    
    1713 1719
                ; let all_rules = rules_acc ++ existing_rules
    
    1714 1720
                      -- all_rules: we look both in the rules_acc (generated by this invocation
    
    ... ... @@ -3102,30 +3108,15 @@ mkCallUDs' env f args
    3102 3108
         -- For "invisibleFunArg", which are the type-class dictionaries,
    
    3103 3109
         -- we decide on a case by case basis if we want to specialise
    
    3104 3110
         -- on this argument; if so, SpecDict, if not UnspecArg
    
    3105
    -    mk_spec_arg arg (Anon pred af)
    
    3111
    +    mk_spec_arg arg (Anon _pred af)
    
    3106 3112
           | isInvisibleFunArg af
    
    3107
    -      , interestingDict arg (scaledThing pred)
    
    3113
    +      , interestingDict env arg
    
    3114
    +      -- , interestingDict arg (scaledThing pred)
    
    3108 3115
                   -- See Note [Interesting dictionary arguments]
    
    3109 3116
           = SpecDict arg
    
    3110 3117
     
    
    3111 3118
           | otherwise = UnspecArg
    
    3112 3119
     
    
    3113
    -{-
    
    3114
    -Note [Ticks on applications]
    
    3115
    -~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    3116
    -Ticks such as source location annotations can sometimes make their way
    
    3117
    -onto applications (see e.g. #21697). So if we see something like
    
    3118
    -
    
    3119
    -    App (Tick _ f) e
    
    3120
    -
    
    3121
    -we need to descend below the tick to find what the real function being
    
    3122
    -applied is.
    
    3123
    -
    
    3124
    -The resulting RULE also has to be able to match this annotated use
    
    3125
    -site, so we only look through ticks that RULE matching looks through
    
    3126
    -(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
    
    3127
    --}
    
    3128
    -
    
    3129 3120
     wantCallsFor :: SpecEnv -> Id -> Bool
    
    3130 3121
     -- See Note [wantCallsFor]
    
    3131 3122
     wantCallsFor _env f
    
    ... ... @@ -3145,8 +3136,60 @@ wantCallsFor _env f
    3145 3136
           WorkerLikeId {}  -> True
    
    3146 3137
           RepPolyId {}     -> True
    
    3147 3138
     
    
    3148
    -{- Note [wantCallsFor]
    
    3149
    -~~~~~~~~~~~~~~~~~~~~~~
    
    3139
    +interestingDict :: SpecEnv -> CoreExpr -> Bool
    
    3140
    +-- This is a subtle and important function
    
    3141
    +-- See Note [Interesting dictionary arguments]
    
    3142
    +interestingDict env (Var v)  -- See (ID3) and (ID5)
    
    3143
    +  | Just rhs <- maybeUnfoldingTemplate (idUnfolding v)
    
    3144
    +  -- might fail for loop breaker dicts but that seems fine.
    
    3145
    +  = interestingDict env rhs
    
    3146
    +
    
    3147
    +interestingDict env arg  -- Main Plan: use exprIsConApp_maybe
    
    3148
    +  | Cast inner_arg _ <- arg  -- See (ID5)
    
    3149
    +  = if | isConstraintKind $ typeKind $ exprType inner_arg
    
    3150
    +       -- If coercions were always homo-kinded, we'd know
    
    3151
    +       -- that this would be the only case
    
    3152
    +       -> interestingDict env inner_arg
    
    3153
    +
    
    3154
    +       -- Check for an implicit parameter at the top
    
    3155
    +       | Just (cls,_) <- getClassPredTys_maybe arg_ty
    
    3156
    +       , isIPClass cls      -- See (ID4)
    
    3157
    +       -> False
    
    3158
    +
    
    3159
    +       -- Otherwise we are unwrapping a unary type class
    
    3160
    +       | otherwise
    
    3161
    +       -> exprIsHNF arg   -- See (ID7)
    
    3162
    +
    
    3163
    +  | Just (_, _, data_con, _tys, args) <- exprIsConApp_maybe in_scope_env arg
    
    3164
    +  , Just cls <- tyConClass_maybe (dataConTyCon data_con)
    
    3165
    +  , not_ip_like                  -- See (ID4)
    
    3166
    +  = if null (classMethods cls)   -- See (ID6)
    
    3167
    +    then any (interestingDict env) args
    
    3168
    +    else True
    
    3169
    +
    
    3170
    +  | otherwise
    
    3171
    +  = not (exprIsTrivial arg) && not_ip_like  -- See (ID8)
    
    3172
    +  where
    
    3173
    +    arg_ty       = exprType arg
    
    3174
    +    not_ip_like  = not (couldBeIPLike arg_ty)
    
    3175
    +    in_scope_env = ISE (substInScopeSet $ se_subst env) realIdUnfolding
    
    3176
    +
    
    3177
    +{- Note [Ticks on applications]
    
    3178
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    3179
    +Ticks such as source location annotations can sometimes make their way
    
    3180
    +onto applications (see e.g. #21697). So if we see something like
    
    3181
    +
    
    3182
    +    App (Tick _ f) e
    
    3183
    +
    
    3184
    +we need to descend below the tick to find what the real function being
    
    3185
    +applied is.
    
    3186
    +
    
    3187
    +The resulting RULE also has to be able to match this annotated use
    
    3188
    +site, so we only look through ticks that RULE matching looks through
    
    3189
    +(see Note [Tick annotations in RULE matching] in GHC.Core.Rules).
    
    3190
    +
    
    3191
    +Note [wantCallsFor]
    
    3192
    +~~~~~~~~~~~~~~~~~~~
    
    3150 3193
     `wantCallsFor env f` says whether the Specialiser should collect calls for
    
    3151 3194
     function `f`; other thing being equal, the fewer calls we collect the better. It
    
    3152 3195
     is False for things we can't specialise:
    
    ... ... @@ -3172,44 +3215,91 @@ collect usage info for imported overloaded functions.
    3172 3215
     
    
    3173 3216
     Note [Interesting dictionary arguments]
    
    3174 3217
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    3175
    -In `mkCallUDs` we only use `SpecDict` for dictionaries of which
    
    3176
    -`interestingDict` holds.  Otherwise we use `UnspecArg`.  Two reasons:
    
    3177
    -
    
    3178
    -* Consider this
    
    3179
    -       \a.\d:Eq a.  let f = ... in ...(f d)...
    
    3180
    -  There really is not much point in specialising f wrt the dictionary d,
    
    3181
    -  because the code for the specialised f is not improved at all, because
    
    3182
    -  d is lambda-bound.  We simply get junk specialisations.
    
    3183
    -
    
    3184
    -* Consider this (#25703):
    
    3185
    -     f :: (Eq a, Show b) => a -> b -> INt
    
    3186
    -     goo :: forall x. (Eq x) => x -> blah
    
    3187
    -     goo @x (d:Eq x) (arg:x) = ...(f @x @Int d $fShowInt)...
    
    3188
    -  If we built a `ci_key` with a (SpecDict d) for `d`, we would end up
    
    3189
    -  discarding the call at the `\d`.  But if we use `UnspecArg` for that
    
    3190
    -  uninteresting `d`, we'll get a `ci_key` of
    
    3191
    -      f @x @Int UnspecArg (SpecDict $fShowInt)
    
    3192
    -  and /that/ can float out to f's definition and specialise nicely.
    
    3193
    -  Hooray.  (NB: the call can float only if `-fpolymorphic-specialisation`
    
    3194
    -  is on; otherwise it'll be trapped by the `\@x -> ...`.)(
    
    3195
    -
    
    3196
    -What is "interesting"?  (See `interestingDict`.)  Just that it has *some*
    
    3197
    -structure.  But what about variables?  We look in the variable's /unfolding/.
    
    3198
    -And that means that we must be careful to ensure that dictionaries /have/
    
    3199
    -unfoldings,
    
    3200
    -
    
    3201
    -* cloneBndrSM discards non-Stable unfoldings
    
    3202
    -* specBind updates the unfolding after specialisation
    
    3203
    -  See Note [Update unfolding after specialisation]
    
    3204
    -* bindAuxiliaryDict adds an unfolding for an aux dict
    
    3205
    -  see Note [Specialisation modulo dictionary selectors]
    
    3206
    -* specCase adds unfoldings for the new bindings it creates
    
    3207
    -
    
    3208
    -We accidentally lost accurate tracking of local variables for a long
    
    3209
    -time, because cloned variables didn't have unfoldings. But makes a
    
    3210
    -massive difference in a few cases, eg #5113. For nofib as a
    
    3211
    -whole it's only a small win: 2.2% improvement in allocation for ansi,
    
    3212
    -1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.
    
    3218
    +Consider this
    
    3219
    +         \a.\d:Eq a.  let f = ... in ...(f d)...
    
    3220
    +There really is not much point in specialising f wrt the dictionary d,
    
    3221
    +because the code for the specialised f is not improved at all, because
    
    3222
    +d is lambda-bound.  We simply get junk specialisations.
    
    3223
    +
    
    3224
    +What is "interesting"?  Our Main Plan is to use `exprIsConApp_maybe` to see
    
    3225
    +if the argument is a dictionary constructor applied to some arguments, in which
    
    3226
    +case we can clearly specialise. But there are wrinkles:
    
    3227
    +
    
    3228
    +(ID1) Note that we look at the argument /term/, not its /type/.  Suppose the
    
    3229
    +  argument is
    
    3230
    +         (% d1, d2 %) |> co
    
    3231
    +  where co :: (% Eq [a], Show [a] %) ~ F Int a, and `F` is a type family.
    
    3232
    +  Then its type (F Int a) looks very un-informative, but the term is super
    
    3233
    +  helpful.  See #19747 (where missing this point caused a 70x slow down)
    
    3234
    +  and #7785.
    
    3235
    +
    
    3236
    +(ID2) Note that the Main Plan works fine for an argument that is a DFun call,
    
    3237
    +   e.g.    $fOrdList $dOrdInt
    
    3238
    +   because `exprIsConApp_maybe` cleverly deals with DFunId applications.  Good!
    
    3239
    +
    
    3240
    +(ID3) For variables, we look in the variable's /unfolding/.  And that means
    
    3241
    +   that we must be careful to ensure that dictionaries /have/ unfoldings:
    
    3242
    +   * cloneBndrSM discards non-Stable unfoldings
    
    3243
    +   * specBind updates the unfolding after specialisation
    
    3244
    +     See Note [Update unfolding after specialisation]
    
    3245
    +   * bindAuxiliaryDict adds an unfolding for an aux dict
    
    3246
    +     see Note [Specialisation modulo dictionary selectors]
    
    3247
    +   * specCase adds unfoldings for the new bindings it creates
    
    3248
    +
    
    3249
    +   We accidentally lost accurate tracking of local variables for a long
    
    3250
    +   time, because cloned variables didn't have unfoldings. But makes a
    
    3251
    +   massive difference in a few cases, eg #5113. For nofib as a
    
    3252
    +   whole it's only a small win: 2.2% improvement in allocation for ansi,
    
    3253
    +   1.2% for bspt, but mostly 0.0!  Average 0.1% increase in binary size.
    
    3254
    +
    
    3255
    +(ID4) We must be very careful not to specialise on a "dictionary" that is, or contains
    
    3256
    +   an implicit parameter, because implicit parameters are emphatically not singleton
    
    3257
    +   types.  See #25999:
    
    3258
    +     useImplicit :: (?i :: Int) => Int
    
    3259
    +     useImplicit = ?i + 1
    
    3260
    +
    
    3261
    +     foo = let ?i = 1 in (useImplicit, let ?i = 2 in useImplicit)
    
    3262
    +   Both calls to `useImplicit` are at type `?i::Int`, but they pass different values.
    
    3263
    +   We must not specialise on implicit parameters!  Hence the call to `couldBeIPLike`.
    
    3264
    +
    
    3265
    +(ID5) Suppose the argument is (e |> co).  Can we rely on `exprIsConApp_maybe` to deal
    
    3266
    +   with the coercion.  No!  That only works if (co :: C t1 ~ C t2) with the same type
    
    3267
    +   constructor at the top of both sides.  But see the example in (ID1), where that
    
    3268
    +   is not true.  For thes same reason, we can't rely on `exprIsConApp_maybe` to look
    
    3269
    +   through unfoldings (because there might be a cast inside), hence dealing with
    
    3270
    +   expandable unfoldings in `interestingDict` directly.
    
    3271
    +
    
    3272
    +(ID6) The Main Plan says that it's worth specialising if the argument is an application
    
    3273
    +   of a dictionary contructor.  But what if the dictionary has no methods?  Then we
    
    3274
    +   gain nothing by specialising, unless the /superclasses/ are interesting.   A case
    
    3275
    +   in point is constraint tuples (% d1, .., dn %); a constraint N-tuple is a class
    
    3276
    +   with N superclasses and no methods.
    
    3277
    +
    
    3278
    +(ID7) A unary (single-method) class is currently represented by (meth |> co).  We
    
    3279
    +   will unwrap the cast (see (ID5)) and then want to reply "yes" if the method
    
    3280
    +   has any struture.  We rather arbitrarily use `exprIsHNF` for this.  (We plan a
    
    3281
    +   new story for unary classes, see #23109, and this special case will become
    
    3282
    +   irrelevant.)
    
    3283
    +
    
    3284
    +(ID8) Sadly, if `exprIsConApp_maybe` says Nothing, we still want to treat a
    
    3285
    +   non-trivial argument as interesting. In T19695 we have this:
    
    3286
    +      askParams :: Monad m => blah
    
    3287
    +      mhelper   :: MonadIO m => blah
    
    3288
    +      mhelper (d:MonadIO m) = ...(askParams @m ($p1 d))....
    
    3289
    +   where `$p1` is the superclass selector for `MonadIO`.  Now, if `mhelper` is
    
    3290
    +   specialised at `Handler` we'll get this call in the specialised `$smhelper`:
    
    3291
    +            askParams @Handler ($p1 $fMonadIOHandler)
    
    3292
    +   and we /definitely/ want to specialise that, even though the argument isn't
    
    3293
    +   visibly a dictionary application.  In fact the specialiser fires the superclass
    
    3294
    +   selector rule (see Note [Fire rules in the specialiser]), so we get
    
    3295
    +            askParams @Handler ($cp1MonadIO $fMonadIOIO)
    
    3296
    +   but it /still/ doesn't look like a dictionary application.
    
    3297
    +
    
    3298
    +   Conclusion: we optimistically assume that any non-trivial argument is worth
    
    3299
    +   specialising on.
    
    3300
    +
    
    3301
    +   So why do the `exprIsConApp_maybe` and `Cast` stuff? Because we want to look
    
    3302
    +   under type-family casts (ID1) and constraint tuples (ID6).
    
    3213 3303
     
    
    3214 3304
     Note [Update unfolding after specialisation]
    
    3215 3305
     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    ... ... @@ -3237,6 +3327,7 @@ Consider (#21848)
    3237 3327
     Now `f` turns into:
    
    3238 3328
     
    
    3239 3329
       f @a @b (dd :: D a) (ds :: Show b) a b
    
    3330
    +
    
    3240 3331
          = let dc :: D a = %p1 dd  -- Superclass selection
    
    3241 3332
            in meth @a dc ....
    
    3242 3333
               meth @a dc ....
    
    ... ... @@ -3252,27 +3343,6 @@ in the NonRec case of specBind. (This is too exotic to trouble with
    3252 3343
     the Rec case.)
    
    3253 3344
     -}
    
    3254 3345
     
    
    3255
    -interestingDict :: CoreExpr -> Type -> Bool
    
    3256
    --- A dictionary argument is interesting if it has *some* structure,
    
    3257
    --- see Note [Interesting dictionary arguments]
    
    3258
    --- NB: "dictionary" arguments include constraints of all sorts,
    
    3259
    ---     including equality constraints; hence the Coercion case
    
    3260
    --- To make this work, we need to ensure that dictionaries have
    
    3261
    --- unfoldings in them.
    
    3262
    -interestingDict arg arg_ty
    
    3263
    -  | not (typeDeterminesValue arg_ty) = False   -- See Note [Type determines value]
    
    3264
    -  | otherwise                        = go arg
    
    3265
    -  where
    
    3266
    -    go (Var v)               =  hasSomeUnfolding (idUnfolding v)
    
    3267
    -                             || isDataConWorkId v
    
    3268
    -    go (Type _)              = False
    
    3269
    -    go (Coercion _)          = False
    
    3270
    -    go (App fn (Type _))     = go fn
    
    3271
    -    go (App fn (Coercion _)) = go fn
    
    3272
    -    go (Tick _ a)            = go a
    
    3273
    -    go (Cast e _)            = go e
    
    3274
    -    go _                     = True
    
    3275
    -
    
    3276 3346
     thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
    
    3277 3347
     thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
    
    3278 3348
             (MkUD {ud_binds = db2, ud_calls = calls2})
    

  • 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,
    
    ... ... @@ -125,9 +125,12 @@ isDictTy ty = isClassPred pred
    125 125
       where
    
    126 126
         (_, pred) = splitInvisPiTys ty
    
    127 127
     
    
    128
    +-- | Is the type *guaranteed* to determine the value?
    
    129
    +--
    
    130
    +-- Might say No even if the type does determine the value. (See the Note)
    
    128 131
     typeDeterminesValue :: Type -> Bool
    
    129 132
     -- See Note [Type determines value]
    
    130
    -typeDeterminesValue ty = isDictTy ty && not (isIPLikePred ty)
    
    133
    +typeDeterminesValue ty = isDictTy ty && not (couldBeIPLike ty)
    
    131 134
     
    
    132 135
     getClassPredTys :: HasDebugCallStack => PredType -> (Class, [Type])
    
    133 136
     getClassPredTys ty = case getClassPredTys_maybe ty of
    
    ... ... @@ -170,6 +173,10 @@ So we treat implicit params just like ordinary arguments for the
    170 173
     purposes of specialisation.  Note that we still want to specialise
    
    171 174
     functions with implicit params if they have *other* dicts which are
    
    172 175
     class params; see #17930.
    
    176
    +
    
    177
    +It's also not always possible to infer that a type determines the value
    
    178
    +if type families are in play. See #19747 for one such example.
    
    179
    +
    
    173 180
     -}
    
    174 181
     
    
    175 182
     -- --------------------- Equality predicates ---------------------------------
    
    ... ... @@ -410,44 +417,44 @@ isCallStackTy ty
    410 417
       | otherwise
    
    411 418
       = False
    
    412 419
     
    
    413
    --- --------------------- isIPLike and mentionsIP  --------------------------
    
    420
    +-- --------------------- couldBeIPLike and mightMentionIP  --------------------------
    
    414 421
     --                 See Note [Local implicit parameters]
    
    415 422
     
    
    416
    -isIPLikePred :: Type -> Bool
    
    423
    +couldBeIPLike :: Type -> Bool
    
    417 424
     -- Is `pred`, or any of its superclasses, an implicit parameter?
    
    418 425
     -- See Note [Local implicit parameters]
    
    419
    -isIPLikePred pred =
    
    420
    -  mentions_ip_pred initIPRecTc (const True) (const True) pred
    
    421
    -
    
    422
    -mentionsIP :: (Type -> Bool) -- ^ predicate on the string
    
    423
    -           -> (Type -> Bool) -- ^ predicate on the type
    
    424
    -           -> Class
    
    425
    -           -> [Type] -> Bool
    
    426
    --- ^ @'mentionsIP' str_cond ty_cond cls tys@ returns @True@ if:
    
    426
    +couldBeIPLike pred
    
    427
    +  = might_mention_ip1 initIPRecTc (const True) (const True) pred
    
    428
    +
    
    429
    +mightMentionIP :: (Type -> Bool) -- ^ predicate on the string
    
    430
    +               -> (Type -> Bool) -- ^ predicate on the type
    
    431
    +               -> Class
    
    432
    +               -> [Type] -> Bool
    
    433
    +-- ^ @'mightMentionIP' str_cond ty_cond cls tys@ returns @True@ if:
    
    427 434
     --
    
    428 435
     --    - @cls tys@ is of the form @IP str ty@, where @str_cond str@ and @ty_cond ty@
    
    429 436
     --      are both @True@,
    
    430 437
     --    - or any superclass of @cls tys@ has this property.
    
    431 438
     --
    
    432 439
     -- See Note [Local implicit parameters]
    
    433
    -mentionsIP = mentions_ip initIPRecTc
    
    440
    +mightMentionIP = might_mention_ip initIPRecTc
    
    434 441
     
    
    435
    -mentions_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
    
    436
    -mentions_ip rec_clss str_cond ty_cond cls tys
    
    442
    +might_mention_ip :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Class -> [Type] -> Bool
    
    443
    +might_mention_ip rec_clss str_cond ty_cond cls tys
    
    437 444
       | Just (str_ty, ty) <- isIPPred_maybe cls tys
    
    438 445
       = str_cond str_ty && ty_cond ty
    
    439 446
       | otherwise
    
    440
    -  = or [ mentions_ip_pred rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
    
    447
    +  = or [ might_mention_ip1 rec_clss str_cond ty_cond (classMethodInstTy sc_sel_id tys)
    
    441 448
            | sc_sel_id <- classSCSelIds cls ]
    
    442 449
     
    
    443 450
     
    
    444
    -mentions_ip_pred :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
    
    445
    -mentions_ip_pred rec_clss str_cond ty_cond ty
    
    451
    +might_mention_ip1 :: RecTcChecker -> (Type -> Bool) -> (Type -> Bool) -> Type -> Bool
    
    452
    +might_mention_ip1 rec_clss str_cond ty_cond ty
    
    446 453
       | Just (cls, tys) <- getClassPredTys_maybe ty
    
    447 454
       , let tc = classTyCon cls
    
    448 455
       , Just rec_clss' <- if isTupleTyCon tc then Just rec_clss
    
    449 456
                           else checkRecTc rec_clss tc
    
    450
    -  = mentions_ip rec_clss' str_cond ty_cond cls tys
    
    457
    +  = might_mention_ip rec_clss' str_cond ty_cond cls tys
    
    451 458
       | otherwise
    
    452 459
       = False -- Includes things like (D []) where D is
    
    453 460
               -- a Constraint-ranged family; #7785
    
    ... ... @@ -460,7 +467,7 @@ initIPRecTc = setRecTcMaxBound 1 initRecTc
    460 467
     See also wrinkle (SIP1) in Note [Shadowing of implicit parameters] in
    
    461 468
     GHC.Tc.Solver.Dict.
    
    462 469
     
    
    463
    -The function isIPLikePred tells if this predicate, or any of its
    
    470
    +The function couldBeIPLike tells if this predicate, or any of its
    
    464 471
     superclasses, is an implicit parameter.
    
    465 472
     
    
    466 473
     Why are implicit parameters special?  Unlike normal classes, we can
    
    ... ... @@ -468,7 +475,7 @@ have local instances for implicit parameters, in the form of
    468 475
        let ?x = True in ...
    
    469 476
     So in various places we must be careful not to assume that any value
    
    470 477
     of the right type will do; we must carefully look for the innermost binding.
    
    471
    -So isIPLikePred checks whether this is an implicit parameter, or has
    
    478
    +So couldBeIPLike checks whether this is an implicit parameter, or has
    
    472 479
     a superclass that is an implicit parameter.
    
    473 480
     
    
    474 481
     Several wrinkles
    
    ... ... @@ -509,16 +516,16 @@ Small worries (Sept 20):
    509 516
       think nothing does.
    
    510 517
     * I'm a little concerned about type variables; such a variable might
    
    511 518
       be instantiated to an implicit parameter.  I don't think this
    
    512
    -  matters in the cases for which isIPLikePred is used, and it's pretty
    
    519
    +  matters in the cases for which couldBeIPLike is used, and it's pretty
    
    513 520
       obscure anyway.
    
    514 521
     * The superclass hunt stops when it encounters the same class again,
    
    515 522
       but in principle we could have the same class, differently instantiated,
    
    516 523
       and the second time it could have an implicit parameter
    
    517 524
     I'm going to treat these as problems for another day. They are all exotic.
    
    518 525
     
    
    519
    -Note [Using typesAreApart when calling mentionsIP]
    
    520
    -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    521
    -We call 'mentionsIP' in two situations:
    
    526
    +Note [Using typesAreApart when calling mightMentionIP]
    
    527
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    528
    +We call 'mightMentionIP' in two situations:
    
    522 529
     
    
    523 530
       (1) to check that a predicate does not contain any implicit parameters
    
    524 531
           IP str ty, for a fixed literal str and any type ty,
    

  • compiler/GHC/Tc/Solver.hs
    ... ... @@ -1928,7 +1928,7 @@ growThetaTyVars theta tcvs
    1928 1928
       | otherwise  = transCloVarSet mk_next seed_tcvs
    
    1929 1929
       where
    
    1930 1930
         seed_tcvs = tcvs `unionVarSet` tyCoVarsOfTypes ips
    
    1931
    -    (ips, non_ips) = partition isIPLikePred theta
    
    1931
    +    (ips, non_ips) = partition couldBeIPLike theta
    
    1932 1932
                              -- See Note [Inheriting implicit parameters]
    
    1933 1933
     
    
    1934 1934
         mk_next :: VarSet -> VarSet -- Maps current set to newly-grown ones
    

  • 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
    ... ... @@ -2043,10 +2043,10 @@ solveOneFromTheOther ct_i ct_w
    2043 2043
          is_wsc_orig_w = isWantedSuperclassOrigin orig_w
    
    2044 2044
     
    
    2045 2045
          different_level_strategy  -- Both Given
    
    2046
    -       | isIPLikePred pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork  else KeepInert
    
    2047
    -       | otherwise         = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
    
    2046
    +       | couldBeIPLike pred = if lvl_w `strictlyDeeperThan` lvl_i then KeepWork  else KeepInert
    
    2047
    +       | otherwise          = if lvl_w `strictlyDeeperThan` lvl_i then KeepInert else KeepWork
    
    2048 2048
            -- See Note [Replacement vs keeping] part (1)
    
    2049
    -       -- For the isIPLikePred case see Note [Shadowing of implicit parameters]
    
    2049
    +       -- For the couldBeIPLike case see Note [Shadowing of implicit parameters]
    
    2050 2050
            --                               in GHC.Tc.Solver.Dict
    
    2051 2051
     
    
    2052 2052
          same_level_strategy -- Both Given
    

  • compiler/GHC/Tc/Solver/Monad.hs
    ... ... @@ -403,8 +403,8 @@ updInertDicts dict_ct@(DictCt { di_cls = cls, di_ev = ev, di_tys = tys })
    403 403
         -- an implicit parameter (?str :: ty) for the given 'str' and any type 'ty'?
    
    404 404
         does_not_mention_ip_for :: Type -> DictCt -> Bool
    
    405 405
         does_not_mention_ip_for str_ty (DictCt { di_cls = cls, di_tys = tys })
    
    406
    -      = not $ mentionsIP (not . typesAreApart str_ty) (const True) cls tys
    
    407
    -        -- See Note [Using typesAreApart when calling mentionsIP]
    
    406
    +      = not $ mightMentionIP (not . typesAreApart str_ty) (const True) cls tys
    
    407
    +        -- See Note [Using typesAreApart when calling mightMentionIP]
    
    408 408
             -- in GHC.Core.Predicate
    
    409 409
     
    
    410 410
     updInertIrreds :: IrredCt -> TcS ()
    
    ... ... @@ -544,7 +544,7 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
    544 544
       = do { is_callstack    <- is_tyConTy isCallStackTy        callStackTyConName
    
    545 545
            ; is_exceptionCtx <- is_tyConTy isExceptionContextTy exceptionContextTyConName
    
    546 546
            ; let contains_callstack_or_exceptionCtx =
    
    547
    -               mentionsIP
    
    547
    +               mightMentionIP
    
    548 548
                      (const True)
    
    549 549
                         -- NB: the name of the call-stack IP is irrelevant
    
    550 550
                         -- e.g (?foo :: CallStack) counts!
    
    ... ... @@ -562,9 +562,9 @@ updSolvedDicts what dict_ct@(DictCt { di_cls = cls, di_tys = tys, di_ev = ev })
    562 562
     
    
    563 563
         -- Return a predicate that decides whether a type is CallStack
    
    564 564
         -- or ExceptionContext, accounting for e.g. type family reduction, as
    
    565
    -    -- per Note [Using typesAreApart when calling mentionsIP].
    
    565
    +    -- per Note [Using typesAreApart when calling mightMentionIP].
    
    566 566
         --
    
    567
    -    -- See Note [Using isCallStackTy in mentionsIP].
    
    567
    +    -- See Note [Using isCallStackTy in mightMentionIP].
    
    568 568
         is_tyConTy :: (Type -> Bool) -> Name -> TcS (Type -> Bool)
    
    569 569
         is_tyConTy is_eq tc_name
    
    570 570
           = do { (mb_tc, _) <- wrapTcS $ TcM.tryTc $ TcM.tcLookupTyCon tc_name
    
    ... ... @@ -592,14 +592,14 @@ in a different context!
    592 592
     See also Note [Shadowing of implicit parameters], which deals with a similar
    
    593 593
     problem with Given implicit parameter constraints.
    
    594 594
     
    
    595
    -Note [Using isCallStackTy in mentionsIP]
    
    596
    -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    595
    +Note [Using isCallStackTy in mightMentionIP]
    
    596
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    597 597
     To implement Note [Don't add HasCallStack constraints to the solved set],
    
    598 598
     we need to check whether a constraint contains a HasCallStack or HasExceptionContext
    
    599 599
     constraint. We do this using the 'mentionsIP' function, but as per
    
    600
    -Note [Using typesAreApart when calling mentionsIP] we don't want to simply do:
    
    600
    +Note [Using typesAreApart when calling mightMentionIP] we don't want to simply do:
    
    601 601
     
    
    602
    -  mentionsIP
    
    602
    +  mightMentionIP
    
    603 603
         (const True) -- (ignore the implicit parameter string)
    
    604 604
         (isCallStackTy <||> isExceptionContextTy)
    
    605 605
     
    

  • 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/SpecTyFam.hs
    1
    +{-# OPTIONS_GHC -fspecialise-aggressively #-}
    
    2
    +{-# OPTIONS_GHC -fno-spec-constr #-}
    
    3
    +
    
    4
    +module SpecTyFam(main, foo) where
    
    5
    +
    
    6
    +import SpecTyFam_Import (specMe, MaybeShowNum)
    
    7
    +import GHC.Exts
    
    8
    +
    
    9
    +-- We want to see a specialization of `specMe` which doesn't take a dictionary at runtime.
    
    10
    +
    
    11
    +{-# OPAQUE foo #-}
    
    12
    +foo :: Int -> (String,Int)
    
    13
    +foo x = specMe True x
    
    14
    +
    
    15
    +main = print $ sum $ map (snd . foo) [1..1000 :: Int]

  • testsuite/tests/simplCore/should_compile/SpecTyFam.stderr
    1
    +[1 of 2] Compiling SpecTyFam_Import ( SpecTyFam_Import.hs, SpecTyFam_Import.o )
    
    2
    +
    
    3
    +==================== Specialise ====================
    
    4
    +Result size of Specialise = {terms: 31, types: 39, coercions: 8, joins: 0/1}
    
    5
    +
    
    6
    +-- RHS size: {terms: 30, types: 27, coercions: 8, joins: 0/1}
    
    7
    +specMe [InlPrag=INLINABLE] :: forall n a. (Integral n, MaybeShowNum a n) => a -> n -> (String, n)
    
    8
    +[LclIdX,
    
    9
    + Arity=4,
    
    10
    + Unf=Unf{Src=StableUser, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [30 0 0 20] 260 10
    
    11
    +         Tmpl= \ (@n) (@a) ($dIntegral [Occ=Once1] :: Integral n) (irred :: MaybeShowNum a n) (eta [Occ=Once1] :: a) (eta [Occ=Once1] :: n) ->
    
    12
    +                 let {
    
    13
    +                   $dNum :: Num n
    
    14
    +                   [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
    
    15
    +                   $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
    
    16
    +                 case eta of n [Occ=Once1] { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }}]
    
    17
    +specMe
    
    18
    +  = \ (@n) (@a) ($dIntegral :: Integral n) (irred :: MaybeShowNum a n) (eta :: a) (eta :: n) ->
    
    19
    +      let {
    
    20
    +        $dNum :: Num n
    
    21
    +        [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=False, ConLike=False, WorkFree=False, Expandable=True, Guidance=IF_ARGS [] 20 0}]
    
    22
    +        $dNum = GHC.Internal.Classes.$p1CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n))) } in
    
    23
    +      case eta of n { __DEFAULT -> (show @a (GHC.Internal.Classes.$p0CTuple2 @(Show a) @(Num n) (irred `cast` (Sub (SpecTyFam_Import.D:R:MaybeShowNum[0] <a>_N <n>_N) :: MaybeShowNum a n ~R# (Show a, Num n)))) eta, + @n $dNum n (div @n $dIntegral (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 1#)) (fromInteger @n $dNum (GHC.Internal.Bignum.Integer.IS 2#)))) }
    
    24
    +
    
    25
    +
    
    26
    +
    
    27
    +[2 of 2] Compiling SpecTyFam        ( SpecTyFam.hs, SpecTyFam.o )
    
    28
    +
    
    29
    +==================== Specialise ====================
    
    30
    +Result size of Specialise = {terms: 84, types: 86, coercions: 13, joins: 0/1}
    
    31
    +
    
    32
    +Rec {
    
    33
    +-- RHS size: {terms: 3, types: 4, coercions: 0, joins: 0/0}
    
    34
    +$dCTuple2 :: (Show Bool, Num Int)
    
    35
    +[LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 10}]
    
    36
    +$dCTuple2 = (GHC.Internal.Show.$fShowBool, GHC.Internal.Num.$fNumInt)
    
    37
    +
    
    38
    +-- RHS size: {terms: 19, types: 9, coercions: 0, joins: 0/1}
    
    39
    +$s$wspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (# String, Int #)
    
    40
    +[LclId, Arity=2]
    
    41
    +$s$wspecMe
    
    42
    +  = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) ->
    
    43
    +      let {
    
    44
    +        $dNum :: Num Int
    
    45
    +        [LclId, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
    
    46
    +        $dNum = GHC.Internal.Num.$fNumInt } in
    
    47
    +      case eta1 of n1 [Occ=Once1] { __DEFAULT -> (# GHC.Internal.Show.$fShowBool_$cshow eta, GHC.Internal.Num.$fNumInt_$c+ n1 (GHC.Internal.Real.$fIntegralInt_$cdiv (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 1#)) (GHC.Internal.Num.$fNumInt_$cfromInteger (GHC.Internal.Bignum.Integer.IS 2#))) #) }
    
    48
    +
    
    49
    +-- RHS size: {terms: 12, types: 13, coercions: 5, joins: 0/0}
    
    50
    +$sspecMe [InlPrag=INLINABLE[2]] :: Bool -> Int -> (String, Int)
    
    51
    +[LclId,
    
    52
    + Arity=2,
    
    53
    + Unf=Unf{Src=StableSystem, TopLvl=True, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=2,unsat_ok=True,boring_ok=False)
    
    54
    +         Tmpl= \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }}]
    
    55
    +$sspecMe = \ (eta [Occ=Once1] :: Bool) (eta1 [Occ=Once1] :: Int) -> case SpecTyFam_Import.$wspecMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) eta eta1 of { (# ww [Occ=Once1], ww1 [Occ=Once1] #) -> (ww, ww1) }
    
    56
    +end Rec }
    
    57
    +
    
    58
    +-- RHS size: {terms: 6, types: 3, coercions: 5, joins: 0/0}
    
    59
    +foo [InlPrag=OPAQUE] :: Int -> (String, Int)
    
    60
    +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 50 0}]
    
    61
    +foo = \ (x :: Int) -> specMe @Int @Bool GHC.Internal.Real.$fIntegralInt ($dCTuple2 `cast` (Sub (Sym (SpecTyFam_Import.D:R:MaybeShowNum[0] <Bool>_N <Int>_N)) :: (Show Bool, Num Int) ~R# MaybeShowNum Bool Int)) GHC.Internal.Types.True x
    
    62
    +
    
    63
    +-- RHS size: {terms: 37, types: 26, coercions: 0, joins: 0/0}
    
    64
    +main :: State# RealWorld -> (# State# RealWorld, () #)
    
    65
    +[LclId, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=IF_ARGS [0] 301 0}]
    
    66
    +main = \ (eta [OS=OneShot] :: State# RealWorld) -> GHC.Internal.IO.Handle.Text.hPutStr2 GHC.Internal.IO.Handle.FD.stdout (case GHC.Internal.Enum.eftIntFB @(Int -> Int) (GHC.Internal.Base.mapFB @Int @(Int -> Int) @Int (\ (ds :: Int) (ds1 [OS=OneShot] :: Int -> Int) (v [OS=OneShot] :: Int) -> case v of { I# ipv -> ds1 (case ds of { I# y -> GHC.Internal.Types.I# (+# ipv y) }) }) (\ (x :: Int) -> case foo x of { (_ [Occ=Dead], y) -> y })) (breakpoint @Int) 1# 1000# (GHC.Internal.Types.I# 0#) of { I# n -> GHC.Internal.Show.itos n (GHC.Internal.Types.[] @Char) }) GHC.Internal.Types.True eta
    
    67
    +
    
    68
    +-- RHS size: {terms: 1, types: 0, coercions: 3, joins: 0/0}
    
    69
    +main :: IO ()
    
    70
    +[LclIdX, Arity=1, Unf=Unf{Src=<vanilla>, TopLvl=False, Value=True, ConLike=True, WorkFree=True, Expandable=True, Guidance=ALWAYS_IF(arity=0,unsat_ok=True,boring_ok=True)}]
    
    71
    +main = main `cast` (Sym (GHC.Internal.Types.N:IO <()>_R) :: (State# RealWorld -> (# State# RealWorld, () #)) ~R# IO ())
    
    72
    +
    
    73
    +
    
    74
    +------ Local rules for imported ids --------
    
    75
    +"SPEC/SpecTyFam $wspecMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). SpecTyFam_Import.$wspecMe @Int @Bool $dIntegral irred = $s$wspecMe
    
    76
    +"SPEC/SpecTyFam specMe @Int @Bool" [2] forall ($dIntegral :: Integral Int) (irred :: MaybeShowNum Bool Int). specMe @Int @Bool $dIntegral irred = $sspecMe
    
    77
    +
    
    78
    +

  • testsuite/tests/simplCore/should_compile/SpecTyFam_Import.hs
    1
    +{-# LANGUAGE TypeFamilies #-}
    
    2
    +{-# LANGUAGE BangPatterns #-}
    
    3
    +{-# LANGUAGE ImplicitParams #-}
    
    4
    +
    
    5
    +module SpecTyFam_Import (specMe, MaybeShowNum) where
    
    6
    +
    
    7
    +import Data.Kind
    
    8
    +
    
    9
    +type family MaybeShowNum a n :: Constraint where
    
    10
    +  MaybeShowNum a n = (Show a, Num n)
    
    11
    +
    
    12
    +{-# INLINABLE specMe #-}
    
    13
    +specMe :: (Integral n, MaybeShowNum a n) => a -> n -> (String,n)
    
    14
    +specMe s !n = (show s, n+1 `div` 2)

  • 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('SpecTyFam',   [ grep_errmsg(r'\$wspecMe')
    
    553
    +                    , extra_files(['SpecTyFam_Import.hs'])
    
    554
    +                    , only_ways(['optasm'])],
    
    555
    +     multimod_compile,
    
    556
    +     ['SpecTyFam', '-O2 -ddump-spec -dsuppress-uniques -dno-typeable-binds -dppr-cols=1000'])