[Git][ghc/ghc][wip/T17966] Major improvements to the specialiser
Simon Peyton Jones
gitlab at gitlab.haskell.org
Wed Apr 1 09:18:03 UTC 2020
Simon Peyton Jones pushed to branch wip/T17966 at Glasgow Haskell Compiler / GHC
Commits:
a8b2ae43 by Simon Peyton Jones at 2020-04-01T10:16:56+01:00
Major improvements to the specialiser
This patch is joint work of Alexis King and Simon PJ. It does some
significant refactoring of the type-class specialiser. Main highlights:
* We can specialise functions with types like
f :: Eq a => a -> Ord b => b => blah
where the classes aren't all at the front (#16473). Here we can
correctly specialise 'f' based on a call like
f @Int @Bool dEqInt x dOrdBool
This change really happened in an earlier patch
commit 2d0cf6252957b8980d89481ecd0b79891da4b14b
Author: Sandy Maguire <sandy at sandymaguire.me>
Date: Thu May 16 12:12:10 2019 -0400
work that this new patch builds directly on that work, and refactors
it a bit.
* We can specialise functions with implicit parameters (#17930)
g :: (?foo :: Bool, Show a) => a -> String
Previously we could not, but now they behave just like a non-class
argument as in 'f' above.
* We can specialise under-saturated calls, where some (but not all of
the dictionary arguments are provided (#17966). For example, we can
specialise the above 'f' based on a call
map (f @Int dEqInt) xs
even though we don't (and can't) give Ord dictionary.
This may sound exotic, but #17966 is a program from the wild, and
showed significant perf loss for functions like f, if you need
saturation of all dictionaries.
* We fix a buglet in which a floated dictionary had a bogus demand
(#17810), by using zapIdDemandInfo in the NonRec case of specBind.
* A tiny side benefit: we can drop dead arguments to specialised
functions; see Note [Drop dead args from specialisations]
* Fixed a bug in deciding what dictionaries are "interesting"; see
Note [Keep the old dictionaries interesting]
This is all achieved by by building on Sandy Macguire's work in
defining SpecArg, which mkCallUDs uses to describe the arguments of
the call. Main changes:
* Main work is in specHeader, which marched down the [InBndr] from the
function definition and the [SpecArg] from the call site, together.
* specCalls no longer has an arity check; the entire mechanism now
handles unders-saturated calls fine.
* mkCallUDs decides on an argument-by-argument basis whether to
specialise a particular dictionary argument; this is new.
See mk_spec_arg in mkCallUDs.
It looks as if there are many more lines of code, but I think that
all the extra lines are comments!
- - - - -
15 changed files:
- compiler/GHC/Core/Op/Specialise.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Unfold.hs
- compiler/GHC/HsToCore/Binds.hs
- testsuite/tests/perf/compiler/T16473.stdout
- testsuite/tests/simplCore/should_compile/Makefile
- + testsuite/tests/simplCore/should_compile/T17810.hs
- + testsuite/tests/simplCore/should_compile/T17810a.hs
- + testsuite/tests/simplCore/should_compile/T17930.hs
- + testsuite/tests/simplCore/should_compile/T17930.stderr
- + testsuite/tests/simplCore/should_compile/T17966.hs
- + testsuite/tests/simplCore/should_compile/T17966.stdout
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/spec004.hs
- + testsuite/tests/simplCore/should_compile/spec004.stderr
Changes:
=====================================
compiler/GHC/Core/Op/Specialise.hs
=====================================
@@ -22,7 +22,7 @@ import GHC.Core.Predicate
import GHC.Types.Module( Module, HasModule(..) )
import GHC.Core.Coercion( Coercion )
import GHC.Core.Op.Monad
-import qualified GHC.Core.Subst
+import qualified GHC.Core.Subst as Core
import GHC.Core.Unfold
import GHC.Types.Var ( isLocalVar )
import GHC.Types.Var.Set
@@ -30,13 +30,15 @@ import GHC.Types.Var.Env
import GHC.Core
import GHC.Core.Rules
import GHC.Core.SimpleOpt ( collectBindersPushingCo )
-import GHC.Core.Utils ( exprIsTrivial, mkCast, exprType )
+import GHC.Core.Utils ( exprIsTrivial, getIdFromTrivialExpr_maybe
+ , mkCast, exprType )
import GHC.Core.FVs
import GHC.Core.Arity ( etaExpandToJoinPointRule )
import GHC.Types.Unique.Supply
import GHC.Types.Name
import GHC.Types.Id.Make ( voidArgId, voidPrimId )
-import Maybes ( mapMaybe, isJust )
+import TysPrim ( voidPrimTy )
+import Maybes ( mapMaybe, maybeToList, isJust )
import MonadUtils ( foldlM )
import GHC.Types.Basic
import GHC.Driver.Types
@@ -607,7 +609,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
-- accidentally re-use a unique that's already in use
-- Easiest thing is to do it all at once, as if all the top-level
-- decls were mutually recursive
- top_env = SE { se_subst = GHC.Core.Subst.mkEmptySubst $ mkInScopeSet $ mkVarSet $
+ top_env = SE { se_subst = Core.mkEmptySubst $ mkInScopeSet $ mkVarSet $
bindersOfBinds binds
, se_interesting = emptyVarSet }
@@ -637,189 +639,12 @@ bitten by such instances to revert to the pre-7.10 behavior.
See #10491
-}
--- | An argument that we might want to specialise.
--- See Note [Specialising Calls] for the nitty gritty details.
-data SpecArg
- =
- -- | Type arguments that should be specialised, due to appearing
- -- free in the type of a 'SpecDict'.
- SpecType Type
- -- | Type arguments that should remain polymorphic.
- | UnspecType
- -- | Dictionaries that should be specialised.
- | SpecDict DictExpr
- -- | Value arguments that should not be specialised.
- | UnspecArg
-
-instance Outputable SpecArg where
- ppr (SpecType t) = text "SpecType" <+> ppr t
- ppr UnspecType = text "UnspecType"
- ppr (SpecDict d) = text "SpecDict" <+> ppr d
- ppr UnspecArg = text "UnspecArg"
-
-getSpecDicts :: [SpecArg] -> [DictExpr]
-getSpecDicts = mapMaybe go
- where
- go (SpecDict d) = Just d
- go _ = Nothing
-
-getSpecTypes :: [SpecArg] -> [Type]
-getSpecTypes = mapMaybe go
- where
- go (SpecType t) = Just t
- go _ = Nothing
-
-isUnspecArg :: SpecArg -> Bool
-isUnspecArg UnspecArg = True
-isUnspecArg UnspecType = True
-isUnspecArg _ = False
-
-isValueArg :: SpecArg -> Bool
-isValueArg UnspecArg = True
-isValueArg (SpecDict _) = True
-isValueArg _ = False
-
--- | Given binders from an original function 'f', and the 'SpecArg's
--- corresponding to its usage, compute everything necessary to build
--- a specialisation.
---
--- We will use a running example. Consider the function
---
--- foo :: forall a b. Eq a => Int -> blah
--- foo @a @b dEqA i = blah
---
--- which is called with the 'CallInfo'
---
--- [SpecType T1, UnspecType, SpecDict dEqT1, UnspecArg]
---
--- We'd eventually like to build the RULE
---
--- RULE "SPEC foo @T1 _"
--- forall @a @b (dEqA' :: Eq a).
--- foo @T1 @b dEqA' = $sfoo @b
---
--- and the specialisation '$sfoo'
---
--- $sfoo :: forall b. Int -> blah
--- $sfoo @b = \i -> SUBST[a->T1, dEqA->dEqA'] blah
---
--- The cases for 'specHeader' below are presented in the same order as this
--- running example. The result of 'specHeader' for this example is as follows:
---
--- ( -- Returned arguments
--- env + [a -> T1, deqA -> dEqA']
--- , []
---
--- -- RULE helpers
--- , [b, dx', i]
--- , [T1, b, dx', i]
---
--- -- Specialised function helpers
--- , [b, i]
--- , [dx]
--- , [T1, b, dx_spec, i]
--- )
-specHeader
- :: SpecEnv
- -> [CoreBndr] -- The binders from the original function 'f'
- -> [SpecArg] -- From the CallInfo
- -> SpecM ( -- Returned arguments
- SpecEnv -- Substitution to apply to the body of 'f'
- , [CoreBndr] -- All the remaining unspecialised args from the original function 'f'
-
- -- RULE helpers
- , [CoreBndr] -- Binders for the RULE
- , [CoreArg] -- Args for the LHS of the rule
-
- -- Specialised function helpers
- , [CoreBndr] -- Binders for $sf
- , [DictBind] -- Auxiliary dictionary bindings
- , [CoreExpr] -- Specialised arguments for unfolding
- )
-
--- We want to specialise on type 'T1', and so we must construct a substitution
--- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
--- details.
-specHeader env (bndr : bndrs) (SpecType t : args)
- = do { let env' = extendTvSubstList env [(bndr, t)]
- ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
- ; pure ( env''
- , unused_bndrs
- , rule_bs
- , Type t : rule_es
- , bs'
- , dx
- , Type t : spec_args
- )
- }
-
--- Next we have a type that we don't want to specialise. We need to perform
--- a substitution on it (in case the type refers to 'a'). Additionally, we need
--- to produce a binder, LHS argument and RHS argument for the resulting rule,
--- /and/ a binder for the specialised body.
-specHeader env (bndr : bndrs) (UnspecType : args)
- = do { let (env', bndr') = substBndr env bndr
- ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
- ; pure ( env''
- , unused_bndrs
- , bndr' : rule_bs
- , varToCoreExpr bndr' : rule_es
- , bndr' : bs'
- , dx
- , varToCoreExpr bndr' : spec_args
- )
- }
-
--- Next we want to specialise the 'Eq a' dict away. We need to construct
--- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
--- the nitty-gritty), as a LHS rule and unfolding details.
-specHeader env (bndr : bndrs) (SpecDict d : args)
- = do { inst_dict_id <- newDictBndr env bndr
- ; let (rhs_env2, dx_binds, spec_dict_args')
- = bindAuxiliaryDicts env [bndr] [d] [inst_dict_id]
- ; (env', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader rhs_env2 bndrs args
- ; pure ( env'
- , unused_bndrs
- -- See Note [Evidence foralls]
- , exprFreeIdsList (varToCoreExpr inst_dict_id) ++ rule_bs
- , varToCoreExpr inst_dict_id : rule_es
- , bs'
- , dx_binds ++ dx
- , spec_dict_args' ++ spec_args
- )
- }
-
--- Finally, we have the unspecialised argument 'i'. We need to produce
--- a binder, LHS and RHS argument for the RULE, and a binder for the
--- specialised body.
---
--- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is
--- why 'i' doesn't appear in our RULE above. But we have no guarantee that
--- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
--- this case must be here.
-specHeader env (bndr : bndrs) (UnspecArg : args)
- = do { let (env', bndr') = substBndr env bndr
- ; (env'', unused_bndrs, rule_bs, rule_es, bs', dx, spec_args)
- <- specHeader env' bndrs args
- ; pure ( env''
- , unused_bndrs
- , bndr' : rule_bs
- , varToCoreExpr bndr' : rule_es
- , bndr' : bs'
- , dx
- , varToCoreExpr bndr' : spec_args
- )
- }
-
--- Return all remaining binders from the original function. These have the
--- invariant that they should all correspond to unspecialised arguments, so
--- it's safe to stop processing at this point.
-specHeader env bndrs [] = pure (env, bndrs, [], [], [], [], [])
-specHeader env [] _ = pure (env, [], [], [], [], [], [])
+{- *********************************************************************
+* *
+ Specialising imported functions
+* *
+********************************************************************* -}
-- | Specialise a set of calls to imported bindings
specImports :: DynFlags
@@ -1036,7 +861,7 @@ Avoiding this recursive specialisation loop is the reason for the
-}
data SpecEnv
- = SE { se_subst :: GHC.Core.Subst.Subst
+ = SE { se_subst :: Core.Subst
-- We carry a substitution down:
-- a) we must clone any binding that might float outwards,
-- to avoid name clashes
@@ -1050,8 +875,14 @@ data SpecEnv
-- See Note [Interesting dictionary arguments]
}
+instance Outputable SpecEnv where
+ ppr (SE { se_subst = subst, se_interesting = interesting })
+ = text "SE" <+> braces (sep $ punctuate comma
+ [ text "subst =" <+> ppr subst
+ , text "interesting =" <+> ppr interesting ])
+
specVar :: SpecEnv -> Id -> CoreExpr
-specVar env v = GHC.Core.Subst.lookupIdSubst (text "specVar") (se_subst env) v
+specVar env v = Core.lookupIdSubst (text "specVar") (se_subst env) v
specExpr :: SpecEnv -> CoreExpr -> SpecM (CoreExpr, UsageDetails)
@@ -1081,12 +912,10 @@ specExpr env expr@(App {})
go other _ = specExpr env other
---------------- Lambda/case require dumping of usage details --------------------
-specExpr env e@(Lam _ _) = do
- (body', uds) <- specExpr env' body
- let (free_uds, dumped_dbs) = dumpUDs bndrs' uds
- return (mkLams bndrs' (wrapDictBindsE dumped_dbs body'), free_uds)
+specExpr env e@(Lam {})
+ = specLam env' bndrs' body
where
- (bndrs, body) = collectBinders e
+ (bndrs, body) = collectBinders e
(env', bndrs') = substBndrs env bndrs
-- More efficient to collect a group of binders together all at once
-- and we don't want to split a lambda group with dumped bindings
@@ -1112,6 +941,18 @@ specExpr env (Let bind body)
-- All done
; return (foldr Let body' binds', uds) }
+--------------
+specLam :: SpecEnv -> [OutBndr] -> InExpr -> SpecM (OutExpr, UsageDetails)
+-- The binders have been substituted, but the body has not
+specLam env bndrs body
+ | null bndrs
+ = specExpr env body
+ | otherwise
+ = do { (body', uds) <- specExpr env body
+ ; let (free_uds, dumped_dbs) = dumpUDs bndrs uds
+ ; return (mkLams bndrs (wrapDictBindsE dumped_dbs body'), free_uds) }
+
+--------------
specTickish :: SpecEnv -> Tickish Id -> Tickish Id
specTickish env (Breakpoint ix ids)
= Breakpoint ix [ id' | id <- ids, Var id' <- [specVar env id]]
@@ -1119,6 +960,7 @@ specTickish env (Breakpoint ix ids)
-- should never happen, but it's harmless to drop them anyway.
specTickish _ other_tickish = other_tickish
+--------------
specCase :: SpecEnv
-> CoreExpr -- Scrutinee, already done
-> Id -> [CoreAlt]
@@ -1144,7 +986,7 @@ specCase env scrut' case_bndr [(con, args, rhs)]
subst_prs = (case_bndr, Var case_bndr_flt)
: [ (arg, Var sc_flt)
| (arg, Just sc_flt) <- args `zip` mb_sc_flts ]
- env_rhs' = env_rhs { se_subst = GHC.Core.Subst.extendIdSubstList (se_subst env_rhs) subst_prs
+ env_rhs' = env_rhs { se_subst = Core.extendIdSubstList (se_subst env_rhs) subst_prs
, se_interesting = se_interesting env_rhs `extendVarSetList`
(case_bndr_flt : sc_args_flt) }
@@ -1241,7 +1083,13 @@ specBind :: SpecEnv -- Use this for RHSs
-- No calls for binders of this bind
specBind rhs_env (NonRec fn rhs) body_uds
= do { (rhs', rhs_uds) <- specExpr rhs_env rhs
- ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds fn rhs
+
+ ; let zapped_fn = zapIdDemandInfo fn
+ -- We zap the demand info because the binding may float,
+ -- which would invaidate the demand info (see #17810 for example).
+ -- Destroying demand info is not terrible; specialisation is
+ -- always followed soon by demand analysis.
+ ; (fn', spec_defns, body_uds1) <- specDefn rhs_env body_uds zapped_fn rhs
; let pairs = spec_defns ++ [(fn', rhs')]
-- fn' mentions the spec_defns in its rules,
@@ -1361,8 +1209,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules
specCalls mb_mod env existing_rules calls_for_me fn rhs
-- The first case is the interesting one
- | callSpecArity pis <= fn_arity -- See Note [Specialisation Must Preserve Sharing]
- && notNull calls_for_me -- And there are some calls to specialise
+ | notNull calls_for_me -- And there are some calls to specialise
&& not (isNeverActive (idInlineActivation fn))
-- Don't specialise NOINLINE things
-- See Note [Auto-specialisation and RULES]
@@ -1382,27 +1229,22 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
return ([], [], emptyUDs)
where
- _trace_doc = sep [ ppr rhs_tyvars, ppr rhs_bndrs
- , ppr (idInlineActivation fn) ]
-
- fn_type = idType fn
- fn_arity = idArity fn
- fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here
- pis = fst $ splitPiTys fn_type
- theta = getTheta pis
- n_dicts = length theta
- inl_prag = idInlinePragma fn
- inl_act = inlinePragmaActivation inl_prag
- is_local = isLocalId fn
+ _trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]
+
+ fn_type = idType fn
+ fn_arity = idArity fn
+ fn_unf = realIdUnfolding fn -- Ignore loop-breaker-ness here
+ inl_prag = idInlinePragma fn
+ inl_act = inlinePragmaActivation inl_prag
+ is_local = isLocalId fn
-- Figure out whether the function has an INLINE pragma
-- See Note [Inline specialisations]
- (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
- -- See Note [Account for casts in binding]
- rhs_tyvars = filter isTyVar rhs_bndrs
+ (rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
+ -- See Note [Account for casts in binding]
- in_scope = GHC.Core.Subst.substInScope (se_subst env)
+ in_scope = Core.substInScope (se_subst env)
already_covered :: DynFlags -> [CoreRule] -> [CoreExpr] -> Bool
already_covered dflags new_rules args -- Note [Specialisations already covered]
@@ -1417,38 +1259,43 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
spec_call :: SpecInfo -- Accumulating parameter
-> CallInfo -- Call instance
-> SpecM SpecInfo
- spec_call spec_acc@(rules_acc, pairs_acc, uds_acc)
- (CI { ci_key = call_args, ci_arity = call_arity })
- = ASSERT(call_arity <= fn_arity)
-
- -- See Note [Specialising Calls]
- do { (rhs_env2, unused_bndrs, rule_bndrs, rule_args, unspec_bndrs, dx_binds, spec_args)
- <- specHeader env rhs_bndrs $ dropWhileEndLE isUnspecArg call_args
- ; let rhs_body' = mkLams unused_bndrs rhs_body
+ spec_call spec_acc@(rules_acc, pairs_acc, uds_acc) (CI { ci_key = call_args })
+ = -- See Note [Specialising Calls]
+ do { ( useful, rhs_env2, leftover_bndrs
+ , rule_bndrs, rule_lhs_args
+ , spec_bndrs, dx_binds, spec_args) <- specHeader env rhs_bndrs call_args
+
; dflags <- getDynFlags
- ; if already_covered dflags rules_acc rule_args
+ ; if not useful -- No useful specialisation
+ || already_covered dflags rules_acc rule_lhs_args
then return spec_acc
else -- pprTrace "spec_call" (vcat [ ppr _call_info, ppr fn, ppr rhs_dict_ids
-- , text "rhs_env2" <+> ppr (se_subst rhs_env2)
-- , ppr dx_binds ]) $
- do
- { -- Figure out the type of the specialised function
- let body = mkLams unspec_bndrs rhs_body'
- body_ty = substTy rhs_env2 $ exprType body
- (lam_extra_args, app_args) -- See Note [Specialisations Must Be Lifted]
- | isUnliftedType body_ty -- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs
- , not (isJoinId fn)
- = ([voidArgId], voidPrimId : unspec_bndrs)
- | otherwise = ([], unspec_bndrs)
- join_arity_change = length app_args - length rule_args
+ do { -- Run the specialiser on the specialised RHS
+ -- The "1" suffix is before we maybe add the void arg
+ ; (spec_rhs1, rhs_uds) <- specLam rhs_env2 (spec_bndrs ++ leftover_bndrs) rhs_body
+ ; let spec_fn_ty1 = exprType spec_rhs1
+
+ -- Maybe add a void arg to the specialised function,
+ -- to avoid unlifted bindings
+ -- See Note [Specialisations Must Be Lifted]
+ -- C.f. GHC.Core.Op.WorkWrap.Lib.mkWorkerArgs
+ add_void_arg = isUnliftedType spec_fn_ty1 && not (isJoinId fn)
+ (spec_rhs, spec_fn_ty, rule_rhs_args)
+ | add_void_arg = ( Lam voidArgId spec_rhs1
+ , mkVisFunTy voidPrimTy spec_fn_ty1
+ , voidPrimId : spec_bndrs)
+ | otherwise = (spec_rhs1, spec_fn_ty1, spec_bndrs)
+
+ arity_decr = count isValArg rule_lhs_args - count isId rule_rhs_args
+ join_arity_decr = length rule_lhs_args - length rule_rhs_args
spec_join_arity | Just orig_join_arity <- isJoinId_maybe fn
- = Just (orig_join_arity + join_arity_change)
+ = Just (orig_join_arity - join_arity_decr)
| otherwise
= Nothing
- ; (spec_rhs, rhs_uds) <- specExpr rhs_env2 (mkLams lam_extra_args body)
- ; let spec_id_ty = exprType spec_rhs
- ; spec_f <- newSpecIdSM fn spec_id_ty spec_join_arity
+ ; spec_fn <- newSpecIdSM fn spec_fn_ty spec_join_arity
; this_mod <- getModule
; let
-- The rule to put in the function's specialisation is:
@@ -1476,13 +1323,12 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
inl_act -- Note [Auto-specialisation and RULES]
(idName fn)
rule_bndrs
- rule_args
- (mkVarApps (Var spec_f) app_args)
+ rule_lhs_args
+ (mkVarApps (Var spec_fn) rule_rhs_args)
spec_rule
= case isJoinId_maybe fn of
- Just join_arity -> etaExpandToJoinPointRule join_arity
- rule_wout_eta
+ Just join_arity -> etaExpandToJoinPointRule join_arity rule_wout_eta
Nothing -> rule_wout_eta
-- Add the { d1' = dx1; d2' = dx2 } usage stuff
@@ -1501,7 +1347,7 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
= (inl_prag { inl_inline = NoUserInline }, noUnfolding)
| otherwise
- = (inl_prag, specUnfolding dflags unspec_bndrs spec_app n_dicts fn_unf)
+ = (inl_prag, specUnfolding dflags fn spec_bndrs spec_app arity_decr fn_unf)
spec_app e = e `mkApps` spec_args
@@ -1509,13 +1355,14 @@ specCalls mb_mod env existing_rules calls_for_me fn rhs
-- Adding arity information just propagates it a bit faster
-- See Note [Arity decrease] in GHC.Core.Op.Simplify
-- Copy InlinePragma information from the parent Id.
- -- So if f has INLINE[1] so does spec_f
- spec_f_w_arity = spec_f `setIdArity` max 0 (fn_arity - n_dicts)
- `setInlinePragma` spec_inl_prag
- `setIdUnfolding` spec_unf
- `asJoinId_maybe` spec_join_arity
-
- _rule_trace_doc = vcat [ ppr spec_f, ppr fn_type, ppr spec_id_ty
+ -- So if f has INLINE[1] so does spec_fn
+ spec_f_w_arity = spec_fn `setIdArity` max 0 (fn_arity - arity_decr)
+ `setInlinePragma` spec_inl_prag
+ `setIdUnfolding` spec_unf
+ `asJoinId_maybe` spec_join_arity
+
+ _rule_trace_doc = vcat [ ppr fn <+> dcolon <+> ppr fn_type
+ , ppr spec_fn <+> dcolon <+> ppr spec_fn_ty
, ppr rhs_bndrs, ppr call_args
, ppr spec_rule
]
@@ -1574,33 +1421,44 @@ preserve laziness.
Note [Specialising Calls]
~~~~~~~~~~~~~~~~~~~~~~~~~
-Suppose we have a function:
+Suppose we have a function with a complicated type:
- f :: Int -> forall a b c. (Foo a, Foo c) => Bar -> Qux
- f = \x -> /\ a b c -> \d1 d2 bar -> rhs
+ f :: forall a b c. Int -> Eq a => Show b => c -> Blah
+ f @a @b @c i dEqA dShowA x = blah
and suppose it is called at:
- f 7 @T1 @T2 @T3 dFooT1 dFooT3 bar
+ f 7 @T1 @T2 @T3 dEqT1 ($dfShow dShowT2) t3
-This call is described as a 'CallInfo' whose 'ci_key' is
+This call is described as a 'CallInfo' whose 'ci_key' is:
- [ UnspecArg, SpecType T1, UnspecType, SpecType T3, SpecDict dFooT1
- , SpecDict dFooT3, UnspecArg ]
+ [ SpecType T1, SpecType T2, UnspecType, UnspecArg, SpecDict dEqT1
+ , SpecDict ($dfShow dShowT2), UnspecArg ]
-Why are 'a' and 'c' identified as 'SpecType', while 'b' is 'UnspecType'?
+Why are 'a' and 'b' identified as 'SpecType', while 'c' is 'UnspecType'?
Because we must specialise the function on type variables that appear
free in its *dictionary* arguments; but not on type variables that do not
appear in any dictionaries, i.e. are fully polymorphic.
Because this call has dictionaries applied, we'd like to specialise
the call on any type argument that appears free in those dictionaries.
-In this case, those are (a ~ T1, c ~ T3).
+In this case, those are [a :-> T1, b :-> T2].
+
+We also need to substitute the dictionary binders with their
+specialised dictionaries. The simplest substitution would be
+[dEqA :-> dEqT1, dShowA :-> $dfShow dShowT2], but this duplicates
+work, since `$dfShow dShowT2` is a function application. Therefore, we
+also want to *float the dictionary out* (via bindAuxiliaryDict),
+creating a new dict binding
+
+ dShow1 = $dfShow dShowT2
-As a result, we'd like to generate a function:
+and the substitution [dEqA :-> dEqT1, dShowA :-> dShow1].
- $sf :: Int -> forall b. Bar -> Qux
- $sf = SUBST[a->T1, c->T3, d1->d1', d2->d2'] (\x -> /\ b -> \bar -> rhs)
+With the substitutions in hand, we can generate a specialised function:
+
+ $sf :: forall c. Int -> c -> Blah
+ $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)
Note that the substitution is applied to the whole thing. This is
convenient, but just slightly fragile. Notably:
@@ -1608,20 +1466,71 @@ convenient, but just slightly fragile. Notably:
We must construct a rewrite rule:
- RULE "SPEC f @T1 _ @T3"
- forall (x :: Int) (@b :: Type) (d1' :: Foo T1) (d2' :: Foo T3).
- f x @T1 @b @T3 d1' d2' = $sf x @b
+ RULE "SPEC f @T1 @T2 _"
+ forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).
+ f @T1 @T2 @c i d1 d2 = $sf @c i
-In the rule, d1' and d2' are just wildcards, not used in the RHS. Note
-additionally that 'bar' isn't captured by this rule --- we bind only
+In the rule, d1 and d2 are just wildcards, not used in the RHS. Note
+additionally that 'x' isn't captured by this rule --- we bind only
enough etas in order to capture all of the *specialised* arguments.
-Finally, we must also construct the usage-details
+Note [Drop dead args from specialisations]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When specialising a function, it’s possible some of the arguments may
+actually be dead. For example, consider:
+
+ f :: forall a. () -> Show a => a -> String
+ f x y = show y ++ "!"
+
+We might generate the following CallInfo for `f @Int`:
+
+ [SpecType Int, UnspecArg, SpecDict $dShowInt, UnspecArg]
+
+Normally we’d include both the x and y arguments in the
+specialisation, since we’re not specialising on either of them. But
+that’s silly, since x is actually unused! So we might as well drop it
+in the specialisation:
+
+ $sf :: Int -> String
+ $sf y = show y ++ "!"
+
+ {-# RULE "SPEC f @Int" forall x. f @Int x $dShow = $sf #-}
+
+This doesn’t save us much, since the arg would be removed later by
+worker/wrapper, anyway, but it’s easy to do. Note, however, that we
+only drop dead arguments if:
+
+ 1. We don’t specialise on them.
+ 2. They come before an argument we do specialise on.
+
+Doing the latter would require eta-expanding the RULE, which could
+make it match less often, so it’s not worth it. Doing the former could
+be more useful --- it would stop us from generating pointless
+specialisations --- but it’s more involved to implement and unclear if
+it actually provides much benefit in practice.
- { d1' = dx1; d2' = dx2 }
+Note [Zap occ info in rule binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we generate a specialisation RULE, we need to drop occurrence
+info on the binders. If we don’t, things go wrong when we specialise a
+function like
+
+ f :: forall a. () -> Show a => a -> String
+ f x y = show y ++ "!"
+
+since we’ll generate a RULE like
+
+ RULE "SPEC f @Int" forall x [Occ=Dead].
+ f @Int x $dShow = $sf
+
+and Core Lint complains, even though x only appears on the LHS (due to
+Note [Drop dead args from specialisations]).
-where d1', d2' are cloned versions of d1,d2, with the type substitution
-applied. These auxiliary bindings just avoid duplication of dx1, dx2.
+Why is that a Lint error? Because the arguments on the LHS of a rule
+are syntactically expressions, not patterns, so Lint treats the
+appearance of x as a use rather than a binding. Fortunately, the
+solution is simple: we just make sure to zap the occ info before
+using ids as wildcard binders in a rule.
Note [Account for casts in binding]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1676,56 +1585,6 @@ type correctness issue.) But specialisation rules are strictly for
What this means is that a SPEC rules from auto-specialisation in
module M will be used in other modules only if M.hi has been read for
some other reason, which is actually pretty likely.
--}
-
-bindAuxiliaryDicts
- :: SpecEnv
- -> [DictId] -> [CoreExpr] -- Original dict bndrs, and the witnessing expressions
- -> [DictId] -- A cloned dict-id for each dict arg
- -> (SpecEnv, -- Substitute for all orig_dicts
- [DictBind], -- Auxiliary dict bindings
- [CoreExpr]) -- Witnessing expressions (all trivial)
--- Bind any dictionary arguments to fresh names, to preserve sharing
-bindAuxiliaryDicts env@(SE { se_subst = subst, se_interesting = interesting })
- orig_dict_ids call_ds inst_dict_ids
- = (env', dx_binds, spec_dict_args)
- where
- (dx_binds, spec_dict_args) = go call_ds inst_dict_ids
- env' = env { se_subst = subst `GHC.Core.Subst.extendSubstList`
- (orig_dict_ids `zip` spec_dict_args)
- `GHC.Core.Subst.extendInScopeList` dx_ids
- , se_interesting = interesting `unionVarSet` interesting_dicts }
-
- dx_ids = [dx_id | (NonRec dx_id _, _) <- dx_binds]
- interesting_dicts = mkVarSet [ dx_id | (NonRec dx_id dx, _) <- dx_binds
- , interestingDict env dx ]
- -- See Note [Make the new dictionaries interesting]
-
- go :: [CoreExpr] -> [CoreBndr] -> ([DictBind], [CoreExpr])
- go [] _ = ([], [])
- go (dx:dxs) (dx_id:dx_ids)
- | exprIsTrivial dx = (dx_binds, dx : args)
- | otherwise = (mkDB (NonRec dx_id dx) : dx_binds, Var dx_id : args)
- where
- (dx_binds, args) = go dxs dx_ids
- -- In the first case extend the substitution but not bindings;
- -- in the latter extend the bindings but not the substitution.
- -- For the former, note that we bind the *original* dict in the substitution,
- -- overriding any d->dx_id binding put there by substBndrs
- go _ _ = pprPanic "bindAuxiliaryDicts" (ppr orig_dict_ids $$ ppr call_ds $$ ppr inst_dict_ids)
-
-{-
-Note [Make the new dictionaries interesting]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Important! We're going to substitute dx_id1 for d
-and we want it to look "interesting", else we won't gather *any*
-consequential calls. E.g.
- f d = ...g d....
-If we specialise f for a call (f (dfun dNumInt)), we'll get
-a consequent call (g d') with an auxiliary definition
- d' = df dNumInt
-We want that consequent call to look interesting
-
Note [From non-recursive to recursive]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2061,15 +1920,297 @@ a complete solution; ignoring specialisation for now, INLINABLE functions
don't get properly strictness analysed, for example. But it works well
for examples involving specialisation, which is the dominant use of
INLINABLE. See #4874.
+-}
-
-************************************************************************
+{- *********************************************************************
* *
-\subsubsection{UsageDetails and suchlike}
+ SpecArg, and specHeader
* *
-************************************************************************
+********************************************************************* -}
+
+-- | An argument that we might want to specialise.
+-- See Note [Specialising Calls] for the nitty gritty details.
+data SpecArg
+ =
+ -- | Type arguments that should be specialised, due to appearing
+ -- free in the type of a 'SpecDict'.
+ SpecType Type
+
+ -- | Type arguments that should remain polymorphic.
+ | UnspecType
+
+ -- | Dictionaries that should be specialised. mkCallUDs ensures
+ -- that only "interesting" dictionary arguments get a SpecDict;
+ -- see Note [Interesting dictionary arguments]
+ | SpecDict DictExpr
+
+ -- | Value arguments that should not be specialised.
+ | UnspecArg
+
+instance Outputable SpecArg where
+ ppr (SpecType t) = text "SpecType" <+> ppr t
+ ppr UnspecType = text "UnspecType"
+ ppr (SpecDict d) = text "SpecDict" <+> ppr d
+ ppr UnspecArg = text "UnspecArg"
+
+specArgFreeVars :: SpecArg -> VarSet
+specArgFreeVars (SpecType ty) = tyCoVarsOfType ty
+specArgFreeVars (SpecDict dx) = exprFreeVars dx
+specArgFreeVars UnspecType = emptyVarSet
+specArgFreeVars UnspecArg = emptyVarSet
+
+isSpecDict :: SpecArg -> Bool
+isSpecDict (SpecDict {}) = True
+isSpecDict _ = False
+
+-- | Given binders from an original function 'f', and the 'SpecArg's
+-- corresponding to its usage, compute everything necessary to build
+-- a specialisation.
+--
+-- We will use the running example from Note [Specialising Calls]:
+--
+-- f :: forall a b c. Int -> Eq a => Show b => c -> Blah
+-- f @a @b @c i dEqA dShowA x = blah
+--
+-- Suppose we decide to specialise it at the following pattern:
+--
+-- [ SpecType T1, SpecType T2, UnspecType, UnspecArg
+-- , SpecDict dEqT1, SpecDict ($dfShow dShowT2), UnspecArg ]
+--
+-- We'd eventually like to build the RULE
+--
+-- RULE "SPEC f @T1 @T2 _"
+-- forall (@c :: Type) (i :: Int) (d1 :: Eq T1) (d2 :: Show T2).
+-- f @T1 @T2 @c i d1 d2 = $sf @c i
+--
+-- and the specialisation '$sf'
+--
+-- $sf :: forall c. Int -> c -> Blah
+-- $sf = SUBST[a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1] (\@c i x -> blah)
+--
+-- where dShow1 is a floated binding created by bindAuxiliaryDict.
+--
+-- The cases for 'specHeader' below are presented in the same order as this
+-- running example. The result of 'specHeader' for this example is as follows:
+--
+-- ( -- Returned arguments
+-- env + [a :-> T1, b :-> T2, dEqA :-> dEqT1, dShowA :-> dShow1]
+-- , [x]
+--
+-- -- RULE helpers
+-- , [c, i, d1, d2]
+-- , [T1, T2, c, i, d1, d2]
+--
+-- -- Specialised function helpers
+-- , [c, i, x]
+-- , [dShow1 = $dfShow dShowT2]
+-- , [T1, T2, dEqT1, dShow1]
+-- )
+specHeader
+ :: SpecEnv
+ -> [InBndr] -- The binders from the original function 'f'
+ -> [SpecArg] -- From the CallInfo
+ -> SpecM ( Bool -- True <=> some useful specialisation happened
+ -- Not the same as any (isSpecDict args) because
+ -- the args might be longer than bndrs
+
+ -- Returned arguments
+ , SpecEnv -- Substitution to apply to the body of 'f'
+ , [OutBndr] -- Leftover binders from the original function 'f'
+ -- that don’t have a corresponding SpecArg
+
+ -- RULE helpers
+ , [OutBndr] -- Binders for the RULE
+ , [CoreArg] -- Args for the LHS of the rule
+
+ -- Specialised function helpers
+ , [OutBndr] -- Binders for $sf
+ , [DictBind] -- Auxiliary dictionary bindings
+ , [OutExpr] -- Specialised arguments for unfolding
+ )
+
+-- We want to specialise on type 'T1', and so we must construct a substitution
+-- 'a->T1', as well as a LHS argument for the resulting RULE and unfolding
+-- details.
+specHeader env (bndr : bndrs) (SpecType t : args)
+ = do { let env' = extendTvSubstList env [(bndr, t)]
+ ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( useful
+ , env''
+ , leftover_bndrs
+ , rule_bs
+ , Type t : rule_es
+ , bs'
+ , dx
+ , Type t : spec_args
+ )
+ }
+
+-- Next we have a type that we don't want to specialise. We need to perform
+-- a substitution on it (in case the type refers to 'a'). Additionally, we need
+-- to produce a binder, LHS argument and RHS argument for the resulting rule,
+-- /and/ a binder for the specialised body.
+specHeader env (bndr : bndrs) (UnspecType : args)
+ = do { let (env', bndr') = substBndr env bndr
+ ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( useful
+ , env''
+ , leftover_bndrs
+ , bndr' : rule_bs
+ , varToCoreExpr bndr' : rule_es
+ , bndr' : bs'
+ , dx
+ , varToCoreExpr bndr' : spec_args
+ )
+ }
+
+-- Next we want to specialise the 'Eq a' dict away. We need to construct
+-- a wildcard binder to match the dictionary (See Note [Specialising Calls] for
+-- the nitty-gritty), as a LHS rule and unfolding details.
+specHeader env (bndr : bndrs) (SpecDict d : args)
+ = do { bndr' <- newDictBndr env bndr -- See Note [Zap occ info in rule binders]
+ ; let (env', dx_bind, spec_dict) = bindAuxiliaryDict env bndr bndr' d
+ ; (_, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( True -- Ha! A useful specialisation!
+ , env''
+ , leftover_bndrs
+ -- See Note [Evidence foralls]
+ , exprFreeIdsList (varToCoreExpr bndr') ++ rule_bs
+ , varToCoreExpr bndr' : rule_es
+ , bs'
+ , maybeToList dx_bind ++ dx
+ , spec_dict : spec_args
+ )
+ }
+
+-- Finally, we have the unspecialised argument 'i'. We need to produce
+-- a binder, LHS and RHS argument for the RULE, and a binder for the
+-- specialised body.
+--
+-- NB: Calls to 'specHeader' will trim off any trailing 'UnspecArg's, which is
+-- why 'i' doesn't appear in our RULE above. But we have no guarantee that
+-- there aren't 'UnspecArg's which come /before/ all of the dictionaries, so
+-- this case must be here.
+specHeader env (bndr : bndrs) (UnspecArg : args)
+ = do { -- see Note [Zap occ info in rule binders]
+ let (env', bndr') = substBndr env (zapIdOccInfo bndr)
+ ; (useful, env'', leftover_bndrs, rule_bs, rule_es, bs', dx, spec_args)
+ <- specHeader env' bndrs args
+ ; pure ( useful
+ , env''
+ , leftover_bndrs
+ , bndr' : rule_bs
+ , varToCoreExpr bndr' : rule_es
+ , if isDeadBinder bndr
+ then bs' -- see Note [Drop dead args from specialisations]
+ else bndr' : bs'
+ , dx
+ , varToCoreExpr bndr' : spec_args
+ )
+ }
+
+-- If we run out of binders, stop immediately
+-- See Note [Specialisation Must Preserve Sharing]
+specHeader env [] _ = pure (False, env, [], [], [], [], [], [])
+
+-- Return all remaining binders from the original function. These have the
+-- invariant that they should all correspond to unspecialised arguments, so
+-- it's safe to stop processing at this point.
+specHeader env bndrs []
+ = pure (False, env', bndrs', [], [], [], [], [])
+ where
+ (env', bndrs') = substBndrs env bndrs
+
+
+-- | Binds a dictionary argument to a fresh name, to preserve sharing
+bindAuxiliaryDict
+ :: SpecEnv
+ -> InId -> OutId -> OutExpr -- Original dict binder, and the witnessing expression
+ -> ( SpecEnv -- Substitute for orig_dict_id
+ , Maybe DictBind -- Auxiliary dict binding, if any
+ , OutExpr) -- Witnessing expression (always trivial)
+bindAuxiliaryDict env@(SE { se_subst = subst, se_interesting = interesting })
+ orig_dict_id fresh_dict_id dict_expr
+
+ -- If the dictionary argument is trivial,
+ -- don’t bother creating a new dict binding; just substitute
+ | Just dict_id <- getIdFromTrivialExpr_maybe dict_expr
+ = let env' = env { se_subst = Core.extendSubst subst orig_dict_id dict_expr
+ `Core.extendInScope` dict_id
+ -- See Note [Keep the old dictionaries interesting]
+ , se_interesting = interesting `extendVarSet` dict_id }
+ in (env', Nothing, dict_expr)
+
+ | otherwise -- Non-trivial dictionary arg; make an auxiliary binding
+ = let dict_bind = mkDB (NonRec fresh_dict_id dict_expr)
+ env' = env { se_subst = Core.extendSubst subst orig_dict_id (Var fresh_dict_id)
+ `Core.extendInScope` fresh_dict_id
+ -- See Note [Make the new dictionaries interesting]
+ , se_interesting = interesting `extendVarSet` fresh_dict_id }
+ in (env', Just dict_bind, Var fresh_dict_id)
+
+{-
+Note [Make the new dictionaries interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Important! We're going to substitute dx_id1 for d
+and we want it to look "interesting", else we won't gather *any*
+consequential calls. E.g.
+ f d = ...g d....
+If we specialise f for a call (f (dfun dNumInt)), we'll get
+a consequent call (g d') with an auxiliary definition
+ d' = df dNumInt
+We want that consequent call to look interesting
+
+Note [Keep the old dictionaries interesting]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In bindAuxiliaryDict, we don’t bother creating a new dict binding if
+the dict expression is trivial. For example, if we have
+
+ f = \ @m1 (d1 :: Monad m1) -> ...
+
+and we specialize it at the pattern
+
+ [SpecType IO, SpecArg $dMonadIO]
+
+it would be silly to create a new binding for $dMonadIO; it’s already
+a binding! So we just extend the substitution directly:
+
+ m1 :-> IO
+ d1 :-> $dMonadIO
+
+But this creates a new subtlety: the dict expression might be a dict
+binding we floated out while specializing another function. For
+example, we might have
+
+ d2 = $p1Monad $dMonadIO -- floated out by bindAuxiliaryDict
+ $sg = h @IO d2
+ h = \ @m2 (d2 :: Applicative m2) -> ...
+
+and end up specializing h at the following pattern:
+
+ [SpecType IO, SpecArg d2]
+
+When we created the d2 binding in the first place, we locally marked
+it as interesting while specializing g as described above by
+Note [Make the new dictionaries interesting]. But when we go to
+specialize h, it isn’t in the SpecEnv anymore, so we’ve lost the
+knowledge that we should specialize on it.
+
+To fix this, we have to explicitly add d2 *back* to the interesting
+set. That way, it will still be considered interesting while
+specializing the body of h. See !2913.
-}
+
+{- *********************************************************************
+* *
+ UsageDetails and suchlike
+* *
+********************************************************************* -}
+
data UsageDetails
= MkUD {
ud_binds :: !(Bag DictBind),
@@ -2139,8 +2280,6 @@ data CallInfoSet = CIS Id (Bag CallInfo)
data CallInfo
= CI { ci_key :: [SpecArg] -- All arguments
- , ci_arity :: Int -- The number of variables necessary to bind
- -- all of the specialised arguments
, ci_fvs :: VarSet -- Free vars of the ci_key
-- call (including tyvars)
-- [*not* include the main id itself, of course]
@@ -2186,12 +2325,6 @@ callInfoFVs :: CallInfoSet -> VarSet
callInfoFVs (CIS _ call_info) =
foldr (\(CI { ci_fvs = fv }) vs -> unionVarSet fv vs) emptyVarSet call_info
-computeArity :: [SpecArg] -> Int
-computeArity = length . filter isValueArg . dropWhileEndLE isUnspecArg
-
-callSpecArity :: [TyCoBinder] -> Int
-callSpecArity = length . filter (not . isNamedBinder) . dropWhileEndLE isVisibleBinder
-
getTheta :: [TyCoBinder] -> [PredType]
getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedBinder)
@@ -2202,13 +2335,9 @@ singleCall id args
= MkUD {ud_binds = emptyBag,
ud_calls = unitDVarEnv id $ CIS id $
unitBag (CI { ci_key = args -- used to be tys
- , ci_arity = computeArity args
, ci_fvs = call_fvs }) }
where
- tys = getSpecTypes args
- dicts = getSpecDicts args
- call_fvs = exprsFreeVars dicts `unionVarSet` tys_fvs
- tys_fvs = tyCoVarsOfTypes tys
+ call_fvs = foldr (unionVarSet . specArgFreeVars) emptyVarSet args
-- The type args (tys) are guaranteed to be part of the dictionary
-- types, because they are just the constrained types,
-- and the dictionary is therefore sure to be bound
@@ -2227,42 +2356,47 @@ mkCallUDs env f args
res = mkCallUDs' env f args
mkCallUDs' env f args
- | not (want_calls_for f) -- Imported from elsewhere
- || null theta -- Not overloaded
- = emptyUDs
-
- | not (all type_determines_value theta)
- || not (computeArity ci_key <= idArity f)
- || not (length dicts == length theta)
- || not (any (interestingDict env) dicts) -- Note [Interesting dictionary arguments]
- -- See also Note [Specialisations already covered]
+ | not (want_calls_for f) -- Imported from elsewhere
+ || null ci_key -- No useful specialisation
+ -- See also Note [Specialisations already covered]
= -- pprTrace "mkCallUDs: discarding" _trace_doc
- emptyUDs -- Not overloaded, or no specialisation wanted
+ emptyUDs
| otherwise
= -- pprTrace "mkCallUDs: keeping" _trace_doc
singleCall f ci_key
where
- _trace_doc = vcat [ppr f, ppr args, ppr (map (interestingDict env) dicts)]
+ _trace_doc = vcat [ppr f, ppr args, ppr ci_key]
pis = fst $ splitPiTys $ idType f
- theta = getTheta pis
- constrained_tyvars = tyCoVarsOfTypes theta
+ constrained_tyvars = tyCoVarsOfTypes $ getTheta pis
ci_key :: [SpecArg]
- ci_key = fmap (\(t, a) ->
- case t of
- Named (binderVar -> tyVar)
- | tyVar `elemVarSet` constrained_tyvars
- -> case a of
- Type ty -> SpecType ty
- _ -> pprPanic "ci_key" $ ppr a
- | otherwise
- -> UnspecType
- Anon InvisArg _ -> SpecDict a
- Anon VisArg _ -> UnspecArg
- ) $ zip pis args
-
- dicts = getSpecDicts ci_key
+ ci_key = dropWhileEndLE (not . isSpecDict) $
+ zipWith mk_spec_arg args pis
+ -- Drop trailing args until we get to a SpecDict
+ -- In this way the RULE has as few args as possible,
+ -- which broadens its applicability, since rules only
+ -- fire when saturated
+
+ mk_spec_arg :: CoreExpr -> TyCoBinder -> SpecArg
+ mk_spec_arg arg (Named bndr)
+ | binderVar bndr `elemVarSet` constrained_tyvars
+ = case arg of
+ Type ty -> SpecType ty
+ _ -> pprPanic "ci_key" $ ppr arg
+ | otherwise = UnspecType
+
+ -- For "InvisArg", which are the type-class dictionaries,
+ -- we decide on a case by case basis if we want to specialise
+ -- on this argument; if so, SpecDict, if not UnspecArg
+ mk_spec_arg arg (Anon InvisArg pred)
+ | type_determines_value pred
+ , interestingDict env arg -- Note [Interesting dictionary arguments]
+ = SpecDict arg
+ | otherwise = UnspecArg
+
+ mk_spec_arg _ (Anon VisArg _)
+ = UnspecArg
want_calls_for f = isLocalId f || isJust (maybeUnfoldingTemplate (realIdUnfolding f))
-- For imported things, we gather call instances if
@@ -2282,12 +2416,18 @@ mkCallUDs' env f args
{-
Note [Type determines value]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Only specialise if all overloading is on non-IP *class* params,
-because these are the ones whose *type* determines their *value*. In
-parrticular, with implicit params, the type args *don't* say what the
-value of the implicit param is! See #7101
-
-However, consider
+Only specialise on non-IP *class* params, because these are the ones
+whose *type* determines their *value*. In particular, with implicit
+params, the type args *don't* say what the value of the implicit param
+is! See #7101.
+
+So we treat implicit params just like ordinary arguments for the
+purposes of specialisation. Note that we still want to specialise
+functions with implicit params if they have *other* dicts which are
+class params; see #17930.
+
+One apparent additional complexity involves type families. For
+example, consider
type family D (v::*->*) :: Constraint
type instance D [] = ()
f :: D v => v Char -> Int
@@ -2298,8 +2438,7 @@ and it's good to specialise f at this dictionary.
So the question is: can an implicit parameter "hide inside" a
type-family constraint like (D a). Well, no. We don't allow
type instance D Maybe = ?x:Int
-Hence the IrredPred case in type_determines_value.
-See #7785.
+Hence the IrredPred case in type_determines_value. See #7785.
Note [Interesting dictionary arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2595,20 +2734,20 @@ mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
extendTvSubstList env tv_binds
- = env { se_subst = GHC.Core.Subst.extendTvSubstList (se_subst env) tv_binds }
+ = env { se_subst = Core.extendTvSubstList (se_subst env) tv_binds }
substTy :: SpecEnv -> Type -> Type
-substTy env ty = GHC.Core.Subst.substTy (se_subst env) ty
+substTy env ty = Core.substTy (se_subst env) ty
substCo :: SpecEnv -> Coercion -> Coercion
-substCo env co = GHC.Core.Subst.substCo (se_subst env) co
+substCo env co = Core.substCo (se_subst env) co
substBndr :: SpecEnv -> CoreBndr -> (SpecEnv, CoreBndr)
-substBndr env bs = case GHC.Core.Subst.substBndr (se_subst env) bs of
+substBndr env bs = case Core.substBndr (se_subst env) bs of
(subst', bs') -> (env { se_subst = subst' }, bs')
substBndrs :: SpecEnv -> [CoreBndr] -> (SpecEnv, [CoreBndr])
-substBndrs env bs = case GHC.Core.Subst.substBndrs (se_subst env) bs of
+substBndrs env bs = case Core.substBndrs (se_subst env) bs of
(subst', bs') -> (env { se_subst = subst' }, bs')
cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
@@ -2616,7 +2755,7 @@ cloneBindSM :: SpecEnv -> CoreBind -> SpecM (SpecEnv, SpecEnv, CoreBind)
-- Return the substitution to use for RHSs, and the one to use for the body
cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec bndr rhs)
= do { us <- getUniqueSupplyM
- ; let (subst', bndr') = GHC.Core.Subst.cloneIdBndr subst us bndr
+ ; let (subst', bndr') = Core.cloneIdBndr subst us bndr
interesting' | interestingDict env rhs
= interesting `extendVarSet` bndr'
| otherwise = interesting
@@ -2625,7 +2764,7 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec
cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (Rec pairs)
= do { us <- getUniqueSupplyM
- ; let (subst', bndrs') = GHC.Core.Subst.cloneRecIdBndrs subst us (map fst pairs)
+ ; let (subst', bndrs') = Core.cloneRecIdBndrs subst us (map fst pairs)
env' = env { se_subst = subst'
, se_interesting = interesting `extendVarSetList`
[ v | (v,r) <- pairs, interestingDict env r ] }
@@ -2635,9 +2774,9 @@ newDictBndr :: SpecEnv -> CoreBndr -> SpecM CoreBndr
-- Make up completely fresh binders for the dictionaries
-- Their bindings are going to float outwards
newDictBndr env b = do { uniq <- getUniqueM
- ; let n = idName b
- ty' = substTy env (idType b)
- ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }
+ ; let n = idName b
+ ty' = substTy env (idType b)
+ ; return (mkUserLocal (nameOccName n) uniq ty' (getSrcSpan n)) }
newSpecIdSM :: Id -> Type -> Maybe JoinArity -> SpecM Id
-- Give the new Id a similar occurrence name to the old one
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -17,7 +17,7 @@ module GHC.Core.Subst (
deShadowBinds, substSpec, substRulesForImportedIds,
substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
- lookupIdSubst, lookupTCvSubst, substIdOcc,
+ lookupIdSubst, lookupTCvSubst, substIdType, substIdOcc,
substTickish, substDVarSet, substIdInfo,
-- ** Operations on substitutions
@@ -756,4 +756,3 @@ analyser, so it's possible that the worker is not even in scope any more.
In all all these cases we simply drop the special case, returning to
InlVanilla. The WARN is just so I can see if it happens a lot.
-}
-
=====================================
compiler/GHC/Core/Unfold.hs
=====================================
@@ -172,15 +172,16 @@ mkInlinableUnfolding dflags expr
where
expr' = simpleOptExpr dflags expr
-specUnfolding :: DynFlags -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
+specUnfolding :: DynFlags -> Id -> [Var] -> (CoreExpr -> CoreExpr) -> Arity
-> Unfolding -> Unfolding
-- See Note [Specialising unfoldings]
-- specUnfolding spec_bndrs spec_app arity_decrease unf
-- = \spec_bndrs. spec_app( unf )
--
-specUnfolding dflags spec_bndrs spec_app arity_decrease
+specUnfolding dflags fn spec_bndrs spec_app arity_decrease
df@(DFunUnfolding { df_bndrs = old_bndrs, df_con = con, df_args = args })
- = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs, ppr df )
+ = ASSERT2( arity_decrease == count isId old_bndrs - count isId spec_bndrs
+ , ppr df $$ ppr spec_bndrs $$ ppr (spec_app (Var fn)) $$ ppr arity_decrease )
mkDFunUnfolding spec_bndrs con (map spec_arg args)
-- There is a hard-to-check assumption here that the spec_app has
-- enough applications to exactly saturate the old_bndrs
@@ -194,7 +195,7 @@ specUnfolding dflags spec_bndrs spec_app arity_decrease
-- The beta-redexes created by spec_app will be
-- simplified away by simplOptExpr
-specUnfolding dflags spec_bndrs spec_app arity_decrease
+specUnfolding dflags _ spec_bndrs spec_app arity_decrease
(CoreUnfolding { uf_src = src, uf_tmpl = tmpl
, uf_is_top = top_lvl
, uf_guidance = old_guidance })
@@ -211,7 +212,7 @@ specUnfolding dflags spec_bndrs spec_app arity_decrease
in mkCoreUnfolding src top_lvl new_tmpl guidance
-specUnfolding _ _ _ _ _ = noUnfolding
+specUnfolding _ _ _ _ _ _ = noUnfolding
{- Note [Specialising unfoldings]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -701,7 +701,7 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
- spec_unf = specUnfolding dflags spec_bndrs core_app arity_decrease fn_unf
+ spec_unf = specUnfolding dflags poly_id spec_bndrs core_app arity_decrease fn_unf
spec_id = mkLocalId spec_name spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
=====================================
testsuite/tests/perf/compiler/T16473.stdout
=====================================
@@ -92,6 +92,12 @@ Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: SPEC/Main $fFunctorStateT_$cfmap @Identity _ (Main)
+Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op return (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
@@ -117,18 +123,19 @@ Rule fired: SPEC/Main $fApplicativeStateT_$c<*> @Identity _ (Main)
Rule fired: SPEC/Main $fApplicativeStateT_$c*> @Identity _ (Main)
Rule fired: SPEC/Main $fMonadStateT @Identity _ (Main)
Rule fired: Class op $p1Monad (BUILTIN)
+Rule fired: Class op $p1Applicative (BUILTIN)
+Rule fired: Class op fmap (BUILTIN)
+Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op <*> (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
-Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op <*> (BUILTIN)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op $p1Applicative (BUILTIN)
Rule fired: Class op fmap (BUILTIN)
Rule fired: Class op >>= (BUILTIN)
-Rule fired: Class op fmap (BUILTIN)
Rule fired: SPEC go @(StateT (Sum Int) Identity) (Main)
Rule fired: Class op $p1Monad (BUILTIN)
Rule fired: Class op pure (BUILTIN)
=====================================
testsuite/tests/simplCore/should_compile/Makefile
=====================================
@@ -2,6 +2,11 @@ TOP=../../..
include $(TOP)/mk/boilerplate.mk
include $(TOP)/mk/test.mk
+T17966:
+ $(RM) -f T17966.o T17966.hi
+ - '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -ddump-spec T17966.hs 2> /dev/null | grep 'SPEC'
+ # Expecting a SPEC rule for $cm
+
T17409:
$(RM) -f T17409.o T17409.hi
- '$(TEST_HC)' $(TEST_HC_OPTS) -O -c -dverbose-core2core -dsuppress-uniques T17409.hs 2> /dev/null | grep '\<id\>'
=====================================
testsuite/tests/simplCore/should_compile/T17810.hs
=====================================
@@ -0,0 +1,7 @@
+module T17801 where
+
+import Control.Monad.Except
+import T17810a
+
+f :: ExceptT e (TCMT IO) ()
+f = liftReduce
=====================================
testsuite/tests/simplCore/should_compile/T17810a.hs
=====================================
@@ -0,0 +1,27 @@
+module T17810a where
+
+import Control.Monad.Except
+
+class Monad m => ReadTCState m where
+ locallyTCState :: m ()
+ liftReduce :: m ()
+
+instance ReadTCState m => ReadTCState (ExceptT err m) where
+ locallyTCState = undefined
+ liftReduce = lift liftReduce
+
+instance MonadIO m => ReadTCState (TCMT m) where
+ locallyTCState = (undefined <$> liftReduce) <* TCM (\_ -> return ())
+ liftReduce = undefined
+
+newtype TCMT m a = TCM { unTCM :: () -> m a }
+
+instance MonadIO m => Functor (TCMT m) where
+ fmap f (TCM m) = TCM $ \r -> liftM f (m r )
+
+instance MonadIO m => Applicative (TCMT m) where
+ pure x = TCM (\_ -> return x)
+ (<*>) (TCM mf) (TCM m) = TCM $ \r -> ap (mf r) (m r)
+
+instance MonadIO m => Monad (TCMT m) where
+ (>>=) (TCM m) k = TCM $ \r -> m r >>= \x -> unTCM (k x) r
=====================================
testsuite/tests/simplCore/should_compile/T17930.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE ImplicitParams #-}
+module T17930 where
+
+foo :: (?b :: Bool, Show a) => a -> String
+foo x | ?b = show x ++ "!"
+ | otherwise = show x ++ "."
+{-# INLINABLE[0] foo #-}
+
+str :: String
+str = let ?b = True in foo "Hello"
=====================================
testsuite/tests/simplCore/should_compile/T17930.stderr
=====================================
@@ -0,0 +1,2 @@
+$sfoo :: (?b::Bool) => [Char] -> [Char]
+$sfoo
=====================================
testsuite/tests/simplCore/should_compile/T17966.hs
=====================================
@@ -0,0 +1,20 @@
+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}
+
+-- The issue here is whether $cm gets a specialiation
+-- See #17966
+
+module T17966 where
+
+class C a b where
+ m :: Show c => a -> b -> c -> String
+
+instance Show b => C Bool b where
+ m a b c = show a ++ show b ++ show c
+ {-# INLINABLE [0] m #-}
+
+f :: (C a b, Show c) => a -> b -> c -> String
+f a b c = m a b c ++ "!"
+{-# INLINABLE [0] f #-}
+
+x :: String
+x = f True () (Just 42)
=====================================
testsuite/tests/simplCore/should_compile/T17966.stdout
=====================================
@@ -0,0 +1,4 @@
+ RULES: "SPEC $cm @()" [0]
+ RULES: "SPEC f @Bool @() @(Maybe Integer)" [0]
+"SPEC/T17966 $fShowMaybe_$cshowList @Integer"
+"SPEC/T17966 $fShowMaybe @Integer"
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -319,3 +319,10 @@ test('T17787', [ grep_errmsg(r'foo') ], compile, ['-ddump-simpl -dsuppress-uniq
test('T17901',
normal,
makefile_test, ['T17901'])
+test('T17930', [ grep_errmsg(r'^\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques -dsuppress-idinfo'])
+test('spec004', [ grep_errmsg(r'\$sfoo') ], compile, ['-O -ddump-spec -dsuppress-uniques'])
+test('T17966',
+ normal,
+ makefile_test, ['T17966'])
+# NB: T17810: -fspecialise-aggressively
+test('T17810', normal, multimod_compile, ['T17810', '-fspecialise-aggressively -dcore-lint -O -v0'])
=====================================
testsuite/tests/simplCore/should_compile/spec004.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE RankNTypes #-}
+
+-- Dead arguments should be dropped in specialisations. See !2913.
+
+module ShouldCompile where
+
+foo :: () -> Show a => a -> String
+foo _x y = show y ++ "!"
+{-# NOINLINE[0] foo #-}
+
+bar :: String
+bar = foo () (42 :: Int)
=====================================
testsuite/tests/simplCore/should_compile/spec004.stderr
=====================================
@@ -0,0 +1,84 @@
+
+==================== Specialise ====================
+Result size of Specialise
+ = {terms: 53, types: 46, coercions: 0, joins: 0/0}
+
+-- RHS size: {terms: 14, types: 12, coercions: 0, joins: 0/0}
+$sfoo [InlPrag=NOINLINE[0]] :: Int -> [Char]
+[LclId]
+$sfoo
+ = \ (y :: Int) ->
+ GHC.Base.build
+ @Char
+ (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
+ GHC.Base.foldr
+ @Char
+ @b
+ c
+ (GHC.CString.unpackFoldrCString# @b "!"# c n)
+ (show @Int GHC.Show.$fShowInt y))
+
+-- RHS size: {terms: 17, types: 17, coercions: 0, joins: 0/0}
+foo [InlPrag=NOINLINE[0]] :: forall a. () -> Show a => a -> String
+[LclIdX,
+ Arity=3,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [0 30 0] 150 40},
+ RULES: "SPEC foo @Int" [0]
+ forall (dk :: ()) ($dShow :: Show Int). foo @Int dk $dShow = $sfoo]
+foo
+ = \ (@a) _ [Occ=Dead] ($dShow :: Show a) (y :: a) ->
+ GHC.Base.build
+ @Char
+ (\ (@b) (c [OS=OneShot] :: Char -> b -> b) (n [OS=OneShot] :: b) ->
+ GHC.Base.foldr
+ @Char
+ @b
+ c
+ (GHC.CString.unpackFoldrCString# @b "!"# c n)
+ (show @a $dShow y))
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 20 0}]
+$trModule = "main"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 1, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Prim.Addr#
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 50 0}]
+$trModule = "ShouldCompile"#
+
+-- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
+$trModule :: GHC.Types.TrName
+[LclId,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 20}]
+$trModule = GHC.Types.TrNameS $trModule
+
+-- RHS size: {terms: 3, types: 0, coercions: 0, joins: 0/0}
+ShouldCompile.$trModule :: GHC.Types.Module
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=True, ConLike=True,
+ WorkFree=True, Expandable=True, Guidance=IF_ARGS [] 10 30}]
+ShouldCompile.$trModule = GHC.Types.Module $trModule $trModule
+
+-- RHS size: {terms: 5, types: 1, coercions: 0, joins: 0/0}
+bar :: String
+[LclIdX,
+ Unf=Unf{Src=<vanilla>, TopLvl=True, Value=False, ConLike=False,
+ WorkFree=False, Expandable=False, Guidance=IF_ARGS [] 50 0}]
+bar = foo @Int GHC.Tuple.() GHC.Show.$fShowInt (GHC.Types.I# 42#)
+
+
+
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8b2ae4385fff0ff6255744e2b3a0ba4f86b7b04
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a8b2ae4385fff0ff6255744e2b3a0ba4f86b7b04
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200401/7b8d7dba/attachment-0001.html>
More information about the ghc-commits
mailing list