summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSimon Peyton Jones <simon.peytonjones@gmail.com>2022-04-22 01:06:52 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2022-04-22 14:14:47 -0400
commit2c541f99f5a83cee873b76b3bd46e4d617f5bcd7 (patch)
treeea1b985ce756102e536e363421998330a506bcc4
parent1e4dcf230a50b00350e084ca43e9d098ff865b22 (diff)
downloadhaskell-2c541f99f5a83cee873b76b3bd46e4d617f5bcd7.tar.gz
Improve floated dicts in Specialise
Second fix to #21391. It turned out that we missed calling bringFloatedDictsIntoScope when specialising imports, which led to the same bug as before. I refactored to move that call to a single place, in specCalls, so we can't forget it. This meant making `FloatedDictBinds` into its own type, pairing the dictionary bindings themselves with the set of their binders. Nicer this way.
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs203
-rw-r--r--testsuite/tests/simplCore/should_compile/T21391a.hs34
-rw-r--r--testsuite/tests/simplCore/should_compile/all.T1
3 files changed, 147 insertions, 91 deletions
diff --git a/compiler/GHC/Core/Opt/Specialise.hs b/compiler/GHC/Core/Opt/Specialise.hs
index 5c515dd95b..5fb3b077ea 100644
--- a/compiler/GHC/Core/Opt/Specialise.hs
+++ b/compiler/GHC/Core/Opt/Specialise.hs
@@ -615,8 +615,7 @@ specProgram guts@(ModGuts { mg_module = this_mod
go [] = return ([], emptyUDs)
go (bind:binds) = do (binds', uds) <- go binds
- let env = bringFloatedDictsIntoScope top_env uds
- (bind', uds') <- specBind env bind uds
+ (bind', uds') <- specBind top_env bind uds
return (bind' ++ binds', uds')
-- Specialise the bindings of this module
@@ -690,18 +689,18 @@ spec_imports :: SpecEnv -- Passed in so that all top-level Ids are in s
-- See Note [specImport call stack]
-> RuleBase -- Rules from this module and the home package
-- (but not external packages, which can change)
- -> Bag DictBind -- Dict bindings, used /only/ for filterCalls
+ -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
-- See Note [Avoiding loops in specImports]
-> CallDetails -- Calls for imported things
-> CoreM ( [CoreRule] -- New rules
, [CoreBind] ) -- Specialised bindings
spec_imports top_env callers rule_base dict_binds calls
= do { let import_calls = dVarEnvElts calls
- -- ; debugTraceMsg (text "specImports {" <+>
- -- vcat [ text "calls:" <+> ppr import_calls
- -- , text "dict_binds:" <+> ppr dict_binds ])
+-- ; debugTraceMsg (text "specImports {" <+>
+-- vcat [ text "calls:" <+> ppr import_calls
+-- , text "dict_binds:" <+> ppr dict_binds ])
; (rules, spec_binds) <- go rule_base import_calls
- -- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
+-- ; debugTraceMsg (text "End specImports }" <+> ppr import_calls)
; return (rules, spec_binds) }
where
@@ -710,7 +709,7 @@ spec_imports top_env callers rule_base dict_binds calls
go rb (cis : other_calls)
= do { -- debugTraceMsg (text "specImport {" <+> ppr cis)
; (rules1, spec_binds1) <- spec_import top_env callers rb dict_binds cis
- -- ; debugTraceMsg (text "specImport }" <+> ppr cis)
+ ; -- debugTraceMsg (text "specImport }" <+> ppr cis)
; (rules2, spec_binds2) <- go (extendRuleBaseList rb rules1) other_calls
; return (rules1 ++ rules2, spec_binds1 ++ spec_binds2) }
@@ -719,7 +718,7 @@ spec_import :: SpecEnv -- Passed in so that all top-level Ids are
-> [Id] -- Stack of imported functions being specialised
-- See Note [specImport call stack]
-> RuleBase -- Rules from this module
- -> Bag DictBind -- Dict bindings, used /only/ for filterCalls
+ -> FloatedDictBinds -- Dict bindings, used /only/ for filterCalls
-- See Note [Avoiding loops in specImports]
-> CallInfoSet -- Imported function and calls for it
-> CoreM ( [CoreRule] -- New rules
@@ -743,20 +742,22 @@ spec_import top_env callers rb dict_binds cis@(CIS fn _)
; vis_orphs <- getVisibleOrphanMods
; let rules_for_fn = getRules (RuleEnv [rb, eps_rule_base eps] vis_orphs) fn
+ ; -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs])
; (rules1, spec_pairs, MkUD { ud_binds = dict_binds1, ud_calls = new_calls })
- <- -- debugTraceMsg (text "specImport1" <+> vcat [ppr fn, ppr good_calls, ppr rhs]) >>
- (runSpecM $ specCalls True top_env rules_for_fn good_calls fn rhs)
+ <- runSpecM $ specCalls True top_env dict_binds
+ rules_for_fn good_calls fn rhs
+
; let spec_binds1 = [NonRec b r | (b,r) <- spec_pairs]
-- After the rules kick in we may get recursion, but
-- we rely on a global GlomBinds to sort that out later
-- See Note [Glom the bindings if imported functions are specialised]
-- Now specialise any cascaded calls
- -- ; debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
+ ; -- debugTraceMsg (text "specImport 2" <+> (ppr fn $$ ppr rules1 $$ ppr spec_binds1))
; (rules2, spec_binds2) <- spec_imports top_env
(fn:callers)
(extendRuleBaseList rb rules1)
- (dict_binds `unionBags` dict_binds1)
+ (dict_binds `thenFDBs` dict_binds1)
new_calls
; let final_binds = wrapDictBinds dict_binds1 $
@@ -1123,7 +1124,7 @@ specExpr env expr@(App {})
; let (fun_in', args_out') = rewriteClassOps env fun_in args_out
; (fun_out', uds_fun) <- specExpr env fun_in'
; let uds_call = mkCallUDs env fun_out' args_out'
- ; return (fun_out' `mkApps` args_out', uds_fun `plusUDs` uds_call `plusUDs` uds_args) }
+ ; return (fun_out' `mkApps` args_out', uds_fun `thenUDs` uds_call `thenUDs` uds_args) }
---------------- Lambda/case require dumping of usage details --------------------
specExpr env e@(Lam {})
@@ -1139,7 +1140,7 @@ specExpr env (Case scrut case_bndr ty alts)
; (scrut'', case_bndr', alts', alts_uds)
<- specCase env scrut' case_bndr alts
; return (Case scrut'' case_bndr' (substTy env ty) alts'
- , scrut_uds `plusUDs` alts_uds) }
+ , scrut_uds `thenUDs` alts_uds) }
---------------- Finally, let is the interesting case --------------------
specExpr env (Let bind body)
@@ -1150,8 +1151,7 @@ specExpr env (Let bind body)
; (body', body_uds) <- specExpr body_env body
-- Deal with the bindings
- ; let rhs_env' = bringFloatedDictsIntoScope rhs_env body_uds
- ; (binds', uds) <- specBind rhs_env' bind' body_uds
+ ; (binds', uds) <- specBind rhs_env bind' body_uds
-- All done
; return (foldr Let body' binds', uds) }
@@ -1301,13 +1301,12 @@ to substitute sc -> sc_flt in the RHS
************************************************************************
-}
-bringFloatedDictsIntoScope :: SpecEnv -> UsageDetails -> SpecEnv
-bringFloatedDictsIntoScope env uds =
- -- pprTrace "brought into scope" (ppr dx_bndrs) $
- env{se_subst=subst'}
+bringFloatedDictsIntoScope :: SpecEnv -> FloatedDictBinds -> SpecEnv
+bringFloatedDictsIntoScope env (FDB { fdb_bndrs = dx_bndrs })
+ = -- pprTrace "brought into scope" (ppr dx_bndrs) $
+ env {se_subst=subst'}
where
- dx_bndrs = ud_bs_of_binds uds
- subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs
+ subst' = se_subst env `Core.extendSubstInScopeSet` dx_bndrs
specBind :: SpecEnv -- Use this for RHSs
-> CoreBind -- Binders are already cloned by cloneBindSM,
@@ -1332,7 +1331,7 @@ specBind rhs_env (NonRec fn rhs) body_uds
-- fn' mentions the spec_defns in its rules,
-- so put the latter first
- combined_uds = body_uds1 `plusUDs` rhs_uds
+ combined_uds = body_uds1 `thenUDs` rhs_uds
(free_uds, dump_dbs, float_all) = dumpBindUDs [fn] combined_uds
@@ -1360,7 +1359,7 @@ specBind rhs_env (Rec pairs) body_uds
-- Note [Specialising a recursive group]
= do { let (bndrs,rhss) = unzip pairs
; (rhss', rhs_uds) <- mapAndCombineSM (specExpr rhs_env) rhss
- ; let scope_uds = body_uds `plusUDs` rhs_uds
+ ; let scope_uds = body_uds `thenUDs` rhs_uds
-- Includes binds and calls arising from rhss
; (bndrs1, spec_defns1, uds1) <- specDefns rhs_env scope_uds pairs
@@ -1400,8 +1399,8 @@ specDefns :: SpecEnv
specDefns _env uds []
= return ([], [], uds)
specDefns env uds ((bndr,rhs):pairs)
- = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
- ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs
+ = do { (bndrs1, spec_defns1, uds1) <- specDefns env uds pairs
+ ; (bndr1, spec_defns2, uds2) <- specDefn env uds1 bndr rhs
; return (bndr1 : bndrs1, spec_defns1 ++ spec_defns2, uds2) }
---------------------------
@@ -1415,12 +1414,15 @@ specDefn :: SpecEnv
specDefn env body_uds fn rhs
= do { let (body_uds_without_me, calls_for_me) = callsForMe fn body_uds
rules_for_me = idCoreRules fn
- ; (rules, spec_defns, spec_uds) <- specCalls False env rules_for_me
- calls_for_me fn rhs
+ dict_binds = ud_binds body_uds
+
+ ; (rules, spec_defns, spec_uds) <- specCalls False env dict_binds
+ rules_for_me calls_for_me fn rhs
+
; return ( fn `addIdSpecialisations` rules
, spec_defns
- , body_uds_without_me `plusUDs` spec_uds) }
- -- It's important that the `plusUDs` is this way
+ , body_uds_without_me `thenUDs` spec_uds) }
+ -- It's important that the `thenUDs` is this way
-- round, because body_uds_without_me may bind
-- dictionaries that are used in calls_for_me passed
-- to specDefn. So the dictionary bindings in
@@ -1431,6 +1433,7 @@ specDefn env body_uds fn rhs
specCalls :: Bool -- True => specialising imported fn
-- False => specialising local fn
-> SpecEnv
+ -> FloatedDictBinds -- Just so that we can extend the in-scope set
-> [CoreRule] -- Existing RULES for the fn
-> [CallInfo]
-> OutId -> InExpr
@@ -1444,7 +1447,7 @@ type SpecInfo = ( [CoreRule] -- Specialisation rules
, [(Id,CoreExpr)] -- Specialised definition
, UsageDetails ) -- Usage details from specialised RHSs
-specCalls spec_imp env existing_rules calls_for_me fn rhs
+specCalls spec_imp env dict_binds existing_rules calls_for_me fn rhs
-- The first case is the interesting one
| notNull calls_for_me -- And there are some calls to specialise
&& not (isNeverActive (idInlineActivation fn))
@@ -1460,14 +1463,14 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- See Note [Inline specialisations] for why we do not
-- switch off specialisation for inline functions
- = -- pprTrace "specDefn: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
+ = -- pprTrace "specCalls: some" (ppr fn $$ ppr calls_for_me $$ ppr existing_rules) $
foldlM spec_call ([], [], emptyUDs) calls_for_me
| otherwise -- No calls or RHS doesn't fit our preconceptions
= warnPprTrace (not (exprIsTrivial rhs) && notNull calls_for_me)
"Missed specialisation opportunity" (ppr fn $$ _trace_doc) $
-- Note [Specialisation shape]
- -- pprTrace "specDefn: none" (ppr fn <+> ppr calls_for_me) $
+ -- pprTrace "specCalls: none" (ppr fn <+> ppr calls_for_me) $
return ([], [], emptyUDs)
where
_trace_doc = sep [ ppr rhs_bndrs, ppr (idInlineActivation fn) ]
@@ -1487,6 +1490,9 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
(rhs_bndrs, rhs_body) = collectBindersPushingCo rhs
-- See Note [Account for casts in binding]
+ -- Bring into scope the binders from the floated dicts
+ env_with_dict_bndrs = bringFloatedDictsIntoScope env dict_binds
+
already_covered :: [CoreRule] -> [CoreExpr] -> Bool
already_covered new_rules args -- Note [Specialisations already covered]
= isJust (specLookupRule env fn args (new_rules ++ existing_rules))
@@ -1505,7 +1511,8 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
-- See Note [Specialising DFuns]
; ( useful, rhs_env2, leftover_bndrs
, rule_bndrs, rule_lhs_args
- , spec_bndrs1, dx_binds, spec_args) <- specHeader env rhs_bndrs all_call_args
+ , spec_bndrs1, dx_binds, spec_args) <- specHeader env_with_dict_bndrs
+ rhs_bndrs all_call_args
-- ; pprTrace "spec_call" (vcat [ text "fun: " <+> ppr fn
-- , text "call info: " <+> ppr _ci
@@ -1628,7 +1635,7 @@ specCalls spec_imp env existing_rules calls_for_me fn rhs
; -- pprTrace "spec_call: rule" _rule_trace_doc
return ( spec_rule : rules_acc
, (spec_f_w_arity, spec_rhs) : pairs_acc
- , spec_uds `plusUDs` uds_acc
+ , spec_uds `thenUDs` uds_acc
) } }
-- Convenience function for invoking lookupRule from Specialise
@@ -2556,26 +2563,24 @@ specializing the body of h. See !2913.
********************************************************************* -}
data UsageDetails
- = MkUD {
- ud_binds :: !(Bag DictBind),
- -- See Note [Floated dictionary bindings]
+ = MkUD { ud_binds :: !FloatedDictBinds
+ , ud_calls :: !CallDetails }
+ -- INVARIANT: suppose bs = fdb_bndrs ud_binds
+ -- Then 'calls' may *mention* 'bs',
+ -- but there should be no calls *for* bs
+
+data FloatedDictBinds -- See Note [Floated dictionary bindings]
+ = FDB { fdb_binds :: !(Bag DictBind)
-- The order is important;
- -- in ds1 `union` ds2, bindings in ds2 can depend on those in ds1
+ -- in ds1 `unionBags` ds2, bindings in ds2 can depend on those in ds1
-- (Remember, Bags preserve order in GHC.)
- ud_bs_of_binds :: !IdSet,
- -- ^ The binders of 'ud_binds'.
+ , fdb_bndrs :: !IdSet
+ } -- ^ The binders of 'fdb_binds'.
-- Caches a superset of the expression
- -- `mkVarSet (bindersOfDictBinds ud_binds))`
+ -- `mkVarSet (bindersOfDictBinds fdb_binds))`
-- for later addition to an InScopeSet
- ud_calls :: !CallDetails
-
- -- INVARIANT: suppose bs = bindersOf ud_binds
- -- Then 'calls' may *mention* 'bs',
- -- but there should be no calls *for* bs
- }
-
-- | A 'DictBind' is a binding along with a cached set containing its free
-- variables (both type variables and dictionaries)
data DictBind = DB { db_bind :: CoreBind, db_fvs :: VarSet }
@@ -2673,8 +2678,8 @@ monomorphic, and specialised in one go.
instance Outputable DictBind where
ppr (DB { db_bind = bind, db_fvs = fvs })
- = text "DB" <+> braces (sep [ text "bind:" <+> ppr bind
- , text "fvs: " <+> ppr fvs ])
+ = text "DB" <+> braces (sep [ text "fvs: " <+> ppr fvs
+ , text "bind:" <+> ppr bind ])
instance Outputable UsageDetails where
ppr (MkUD { ud_binds = dbs, ud_calls = calls })
@@ -2682,10 +2687,15 @@ instance Outputable UsageDetails where
[text "binds" <+> equals <+> ppr dbs,
text "calls" <+> equals <+> ppr calls]))
+instance Outputable FloatedDictBinds where
+ ppr (FDB { fdb_binds = binds }) = ppr binds
+
emptyUDs :: UsageDetails
-emptyUDs = MkUD { ud_binds = emptyBag
- , ud_bs_of_binds = emptyVarSet
- , ud_calls = emptyDVarEnv }
+emptyUDs = MkUD { ud_binds = emptyFDBs, ud_calls = emptyDVarEnv }
+
+
+emptyFDBs :: FloatedDictBinds
+emptyFDBs = FDB { fdb_binds = emptyBag, fdb_bndrs = emptyVarSet }
------------------------------------------------------------
type CallDetails = DIdEnv CallInfoSet
@@ -2754,7 +2764,7 @@ getTheta = fmap tyBinderType . filter isInvisibleBinder . filter (not . isNamedB
------------------------------------------------------------
singleCall :: Id -> [SpecArg] -> UsageDetails
singleCall id args
- = MkUD {ud_binds = emptyBag, ud_bs_of_binds = emptyVarSet,
+ = MkUD {ud_binds = emptyFDBs,
ud_calls = unitDVarEnv id $ CIS id $
unitBag (CI { ci_key = args -- used to be tys
, ci_fvs = call_fvs }) }
@@ -2904,13 +2914,20 @@ interestingDict env (Tick _ a) = interestingDict env a
interestingDict env (Cast e _) = interestingDict env e
interestingDict _ _ = True
-plusUDs :: UsageDetails -> UsageDetails -> UsageDetails
-plusUDs (MkUD {ud_binds = db1, ud_bs_of_binds = bs1, ud_calls = calls1})
- (MkUD {ud_binds = db2, ud_bs_of_binds = bs2, ud_calls = calls2})
- = MkUD { ud_binds = db1 `unionBags` db2
- , ud_bs_of_binds = bs1 `unionVarSet` bs2
+thenUDs :: UsageDetails -> UsageDetails -> UsageDetails
+thenUDs (MkUD {ud_binds = db1, ud_calls = calls1})
+ (MkUD {ud_binds = db2, ud_calls = calls2})
+ = MkUD { ud_binds = db1 `thenFDBs` db2
, ud_calls = calls1 `unionCalls` calls2 }
+thenFDBs :: FloatedDictBinds -> FloatedDictBinds -> FloatedDictBinds
+-- Combine FloatedDictBinds
+-- In (dbs1 `thenFDBs` dbs2), dbs2 may mention dbs1 but not vice versa
+thenFDBs (FDB { fdb_binds = dbs1, fdb_bndrs = bs1 })
+ (FDB { fdb_binds = dbs2, fdb_bndrs = bs2 })
+ = FDB { fdb_binds = dbs1 `unionBags` dbs2
+ , fdb_bndrs = bs1 `unionVarSet` bs2 }
+
-----------------------------
_dictBindBndrs :: Bag DictBind -> [Id]
_dictBindBndrs dbs = foldr ((++) . bindersOf . db_bind) [] dbs
@@ -2922,9 +2939,8 @@ mkDB bind = DB { db_bind = bind, db_fvs = bind_fvs bind }
-- | Identify the free variables of a 'CoreBind'
bind_fvs :: CoreBind -> VarSet
bind_fvs (NonRec bndr rhs) = pair_fvs (bndr,rhs)
-bind_fvs (Rec prs) = foldl' delVarSet rhs_fvs bndrs
+bind_fvs (Rec prs) = rhs_fvs `delVarSetList` (map fst prs)
where
- bndrs = map fst prs
rhs_fvs = unionVarSets (map pair_fvs prs)
pair_fvs :: (Id, CoreExpr) -> VarSet
@@ -2949,7 +2965,8 @@ pair_fvs (bndr, rhs) = exprSomeFreeVars interesting rhs
-- pairs, into a single recursive binding.
recWithDumpedDicts :: [(Id,CoreExpr)] -> Bag DictBind -> DictBind
recWithDumpedDicts pairs dbs
- = DB { db_bind = Rec bindings, db_fvs = fvs }
+ = DB { db_bind = Rec bindings
+ , db_fvs = fvs `delVarSetList` map fst bindings }
where
(bindings, fvs) = foldr add ([], emptyVarSet)
(dbs `snocBag` mkDB (Rec pairs))
@@ -2961,28 +2978,28 @@ recWithDumpedDicts pairs dbs
fvs' = fvs_acc `unionVarSet` fvs
snocDictBind :: UsageDetails -> DictBind -> UsageDetails
-snocDictBind uds@MkUD{ud_binds=dbs,ud_bs_of_binds=bs} db
- = uds { ud_binds = dbs `snocBag` db
- , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBind db }
+snocDictBind uds@MkUD{ud_binds= FDB { fdb_binds = dbs, fdb_bndrs = bs }} db
+ = uds { ud_binds = FDB { fdb_binds = dbs `snocBag` db
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
snocDictBinds :: UsageDetails -> [DictBind] -> UsageDetails
-- Add ud_binds to the tail end of the bindings in uds
-snocDictBinds uds@MkUD{ud_binds=binds,ud_bs_of_binds=bs} dbs
- = uds { ud_binds = binds `unionBags` listToBag dbs
- , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBinds dbs }
+snocDictBinds uds@MkUD{ud_binds=FDB{ fdb_binds = binds, fdb_bndrs = bs }} dbs
+ = uds { ud_binds = FDB { fdb_binds = binds `unionBags` listToBag dbs
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
consDictBind :: DictBind -> UsageDetails -> UsageDetails
-consDictBind db uds@MkUD{ud_binds=binds,ud_bs_of_binds=bs}
- = uds { ud_binds = db `consBag` binds
- , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBind db }
+consDictBind db uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs=bs}}
+ = uds { ud_binds = FDB { fdb_binds = db `consBag` binds
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBind db } }
consDictBinds :: [DictBind] -> UsageDetails -> UsageDetails
-consDictBinds dbs uds@MkUD{ud_binds=binds,ud_bs_of_binds=bs}
- = uds { ud_binds = listToBag dbs `unionBags` binds
- , ud_bs_of_binds = bs `extendVarSetList` bindersOfDictBinds dbs }
+consDictBinds dbs uds@MkUD{ud_binds=FDB{fdb_binds = binds, fdb_bndrs = bs}}
+ = uds { ud_binds = FDB{ fdb_binds = listToBag dbs `unionBags` binds
+ , fdb_bndrs = bs `extendVarSetList` bindersOfDictBinds dbs } }
-wrapDictBinds :: Bag DictBind -> [CoreBind] -> [CoreBind]
-wrapDictBinds dbs binds
+wrapDictBinds :: FloatedDictBinds -> [CoreBind] -> [CoreBind]
+wrapDictBinds (FDB { fdb_binds = dbs }) binds
= foldr add binds dbs
where
add (DB { db_bind = bind }) binds = bind : binds
@@ -2996,15 +3013,14 @@ wrapDictBindsE dbs expr
----------------------
dumpUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind)
-- Used at a lambda or case binder; just dump anything mentioning the binder
-dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_bs_of_binds = bs, ud_calls = orig_calls })
+dumpUDs bndrs uds@(MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
| null bndrs = (uds, emptyBag) -- Common in case alternatives
| otherwise = -- pprTrace "dumpUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
(free_uds, dump_dbs)
where
- free_uds = uds { ud_binds = free_dbs, ud_bs_of_binds = free_bs, ud_calls = free_calls }
+ free_uds = uds { ud_binds = free_dbs, ud_calls = free_calls }
bndr_set = mkVarSet bndrs
(free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
- free_bs = bs `minusVarSet` dump_set
free_calls = deleteCallsMentioning dump_set $ -- Drop calls mentioning bndr_set on the floor
deleteCallsFor bndrs orig_calls -- Discard calls for bndr_set; there should be
-- no calls for any of the dicts in dump_dbs
@@ -3015,14 +3031,13 @@ dumpBindUDs :: [CoreBndr] -> UsageDetails -> (UsageDetails, Bag DictBind, Bool)
-- directly or indirectly, by any of the ud_calls; in that case we want to
-- float the binding itself;
-- See Note [Floated dictionary bindings]
-dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_bs_of_binds = bs, ud_calls = orig_calls })
+dumpBindUDs bndrs (MkUD { ud_binds = orig_dbs, ud_calls = orig_calls })
= -- pprTrace "dumpBindUDs" (ppr bndrs $$ ppr free_uds $$ ppr dump_dbs) $
(free_uds, dump_dbs, float_all)
where
- free_uds = MkUD { ud_binds = free_dbs, ud_bs_of_binds = free_bs, ud_calls = free_calls }
+ free_uds = MkUD { ud_binds = free_dbs, ud_calls = free_calls }
bndr_set = mkVarSet bndrs
(free_dbs, dump_dbs, dump_set) = splitDictBinds orig_dbs bndr_set
- free_bs = bs `minusVarSet` dump_set
free_calls = deleteCallsFor bndrs orig_calls
float_all = dump_set `intersectsVarSet` callDetailsFVs free_calls
@@ -3043,10 +3058,10 @@ callsForMe fn uds@MkUD { ud_binds = orig_dbs, ud_calls = orig_calls }
-- refer to fn. See Note [Avoiding loops (DFuns)]
----------------------
-filterCalls :: CallInfoSet -> Bag DictBind -> [CallInfo]
+filterCalls :: CallInfoSet -> FloatedDictBinds -> [CallInfo]
-- Remove dominated calls (Note [Specialising polymorphic dictionaries])
-- and loopy DFuns (Note [Avoiding loops (DFuns)])
-filterCalls (CIS fn call_bag) dbs
+filterCalls (CIS fn call_bag) (FDB { fdb_binds = dbs })
| isDFunId fn -- Note [Avoiding loops (DFuns)] applies only to DFuns
= filter ok_call de_dupd_calls
| otherwise -- Do not apply it to non-DFuns
@@ -3090,18 +3105,23 @@ beats_or_same (CI { ci_key = args1 }) (CI { ci_key = args2 })
go_arg _ _ = False
----------------------
-splitDictBinds :: Bag DictBind -> IdSet -> (Bag DictBind, Bag DictBind, IdSet)
+splitDictBinds :: FloatedDictBinds -> IdSet -> (FloatedDictBinds, Bag DictBind, IdSet)
-- splitDictBinds dbs bndrs returns
-- (free_dbs, dump_dbs, dump_set)
-- where
-- * dump_dbs depends, transitively on bndrs
-- * free_dbs does not depend on bndrs
-- * dump_set = bndrs `union` bndrs(dump_dbs)
-splitDictBinds dbs bndr_set
- = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
+splitDictBinds (FDB { fdb_binds = dbs, fdb_bndrs = bs }) bndr_set
+ = (FDB { fdb_binds = free_dbs
+ , fdb_bndrs = bs `minusVarSet` dump_set }
+ , dump_dbs, dump_set)
+ where
+ (free_dbs, dump_dbs, dump_set)
+ = foldl' split_db (emptyBag, emptyBag, bndr_set) dbs
-- Important that it's foldl' not foldr;
-- we're accumulating the set of dumped ids in dump_set
- where
+
split_db (free_dbs, dump_dbs, dump_idset) db
| DB { db_bind = bind, db_fvs = fvs } <- db
, dump_idset `intersectsVarSet` fvs -- Dump it
@@ -3146,7 +3166,7 @@ mapAndCombineSM :: (a -> SpecM (b, UsageDetails)) -> [a] -> SpecM ([b], UsageDet
mapAndCombineSM _ [] = return ([], emptyUDs)
mapAndCombineSM f (x:xs) = do (y, uds1) <- f x
(ys, uds2) <- mapAndCombineSM f xs
- return (y:ys, uds1 `plusUDs` uds2)
+ return (y:ys, uds1 `thenUDs` uds2)
extendTvSubstList :: SpecEnv -> [(TyVar,Type)] -> SpecEnv
extendTvSubstList env tv_binds
@@ -3176,6 +3196,7 @@ cloneBindSM env@(SE { se_subst = subst, se_interesting = interesting }) (NonRec
, interestingDict env rhs
= interesting `extendVarSet` bndr'
| otherwise = interesting
+-- ; pprTrace "cloneBindSM" (ppr bndr <+> text ":->" <+> ppr bndr') return ()
; return (env, env { se_subst = subst', se_interesting = interesting' }
, NonRec bndr' rhs) }
diff --git a/testsuite/tests/simplCore/should_compile/T21391a.hs b/testsuite/tests/simplCore/should_compile/T21391a.hs
new file mode 100644
index 0000000000..add79e4d8a
--- /dev/null
+++ b/testsuite/tests/simplCore/should_compile/T21391a.hs
@@ -0,0 +1,34 @@
+module T21391a (readYamlFile) where
+
+import Control.Monad (liftM)
+import Control.Monad.Trans.Writer.Strict (tell, WriterT(..))
+
+discard :: a -> b
+discard x = discard x
+
+data Pipe a = MkPipe a
+
+sinkValue :: m ~ ResourceT IO => () -> Pipe (WriterT String m ())
+sinkValue _ = tell' ()
+ where
+ tell' _ = lift' discard (tell "")
+
+ lift' rest mr = MkPipe (liftM rest mr)
+ {-# INLINE [1] lift' #-}
+
+class FromYaml a where
+ fromYaml :: () -> a
+
+readYamlFile :: FromYaml a => a
+readYamlFile = fromYaml (discard sinkValue)
+
+newtype ResourceT m a = ResourceT { unResourceT :: IO a }
+
+instance Monad m => Functor (ResourceT m) where
+ fmap = discard
+instance Monad m => Applicative (ResourceT m) where
+ pure = discard
+ (<*>) = discard
+instance Monad m => Monad (ResourceT m) where
+ (>>=) = discard
+
diff --git a/testsuite/tests/simplCore/should_compile/all.T b/testsuite/tests/simplCore/should_compile/all.T
index cbe344df93..7f1af1be06 100644
--- a/testsuite/tests/simplCore/should_compile/all.T
+++ b/testsuite/tests/simplCore/should_compile/all.T
@@ -405,3 +405,4 @@ test('T17966', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-spec'])
test('T19644', [ grep_errmsg(r'SPEC') ], compile, ['-O -ddump-spec'])
test('T21391', normal, compile, ['-O -dcore-lint'])
+test('T21391a', normal, compile, ['-O -dcore-lint'])