[Git][ghc/ghc][wip/T21909] 10 commits: Refactor the simplifier a bit to fix #22761
Apoorv Ingle (@ani)
gitlab at gitlab.haskell.org
Fri Feb 10 15:17:07 UTC 2023
Apoorv Ingle pushed to branch wip/T21909 at Glasgow Haskell Compiler / GHC
Commits:
e45eb828 by Simon Peyton Jones at 2023-02-10T06:51:28-05:00
Refactor the simplifier a bit to fix #22761
The core change in this commit, which fixes #22761, is that
* In a Core rule, ru_rhs is always occ-analysed.
This means adding a couple of calls to occurAnalyseExpr when
building a Rule, in
* GHC.Core.Rules.mkRule
* GHC.Core.Opt.Simplify.Iteration.simplRules
But diagosing the bug made me stare carefully at the code of the
Simplifier, and I ended up doing some only-loosely-related refactoring.
* I think that RULES could be lost because not every code path
did addBndrRules
* The code around lambdas was very convoluted
It's mainly moving deck chairs around, but I like it more now.
- - - - -
11e0cacb by Rebecca Turner at 2023-02-10T06:52:09-05:00
Detect the `mold` linker
Enables support for the `mold` linker by rui314.
- - - - -
59556235 by parsonsmatt at 2023-02-10T09:53:11-05:00
Add Lift instance for Fixed
- - - - -
c44e5f30 by Sylvain Henry at 2023-02-10T09:53:51-05:00
Testsuite: decrease length001 timeout for JS (#22921)
- - - - -
133516af by Zubin Duggal at 2023-02-10T09:54:27-05:00
compiler: Use NamedFieldPuns for `ModIface_` and `ModIfaceBackend` `NFData`
instances
This is a minor refactor that makes it easy to add and remove fields from
`ModIface_` and `ModIfaceBackend`.
Also change the formatting to make it clear exactly which fields are
fully forced with `rnf`
- - - - -
1360d064 by Apoorv Ingle at 2023-02-10T09:16:39-06:00
Fixes #21909
Constraint simplification loop now depends on `ExpansionFuel` instead of a boolean flag in `CDictCan.cc_pend_sc`.
Pending Givens get a fuel of 3 to start of with while Wanted constraints get a fuel of 1.
This helps pending given constraints to keep up with pending wanted constraints.
Added tests T21909, T21909b
- - - - -
3b745764 by Apoorv Ingle at 2023-02-10T09:16:39-06:00
Change `qci_pend_sc` from `Bool` to `ExpansionFuel`
- - - - -
4e460485 by Apoorv Ingle at 2023-02-10T09:16:39-06:00
abstract default fuel into constants
- - - - -
b5ab37d3 by Apoorv Ingle at 2023-02-10T09:16:39-06:00
added note [SimplifyInfer and UndecidableSuperClasses]
- - - - -
b8c266eb by Apoorv Ingle at 2023-02-10T09:16:39-06:00
make expansion fuel a dynamic flag
- - - - -
28 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/Arity.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/Settings/Constants.hs
- compiler/GHC/SysTools/Info.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Tc/Solver/Canonical.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Types/Constraint.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Unit/Module/ModIface.hs
- docs/users_guide/expected-undocumented-flags.txt
- libraries/base/tests/all.T
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/driver/testlib.py
- + testsuite/tests/simplCore/should_compile/T22761.hs
- + testsuite/tests/simplCore/should_compile/T22761a.hs
- testsuite/tests/simplCore/should_compile/all.T
- + testsuite/tests/typecheck/should_compile/T21909.hs
- + testsuite/tests/typecheck/should_compile/T21909b.hs
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -1300,16 +1300,19 @@ data Unfolding
df_args :: [CoreExpr] -- Args of the data con: types, superclasses and methods,
} -- in positional order
- | CoreUnfolding { -- An unfolding for an Id with no pragma,
- -- or perhaps a NOINLINE pragma
- -- (For NOINLINE, the phase, if any, is in the
- -- InlinePragInfo for this Id.)
- uf_tmpl :: CoreExpr, -- Template; occurrence info is correct
- uf_src :: UnfoldingSource, -- Where the unfolding came from
- uf_is_top :: Bool, -- True <=> top level binding
- uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
- -- See Note [Tying the 'CoreUnfolding' knot]
- uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
+ | CoreUnfolding { -- An unfolding for an Id with no pragma,
+ -- or perhaps a NOINLINE pragma
+ -- (For NOINLINE, the phase, if any, is in the
+ -- InlinePragInfo for this Id.)
+ uf_tmpl :: CoreExpr, -- The unfolding itself (aka "template")
+ -- Always occ-analysed;
+ -- See Note [OccInfo in unfoldings and rules]
+
+ uf_src :: UnfoldingSource, -- Where the unfolding came from
+ uf_is_top :: Bool, -- True <=> top level binding
+ uf_cache :: UnfoldingCache, -- Cache of flags computable from the expr
+ -- See Note [Tying the 'CoreUnfolding' knot]
+ uf_guidance :: UnfoldingGuidance -- Tells about the *size* of the template.
}
-- ^ An unfolding with redundant cached information. Parameters:
--
@@ -1637,14 +1640,37 @@ change was requested by Roman, but it seems to make sense.
Note [OccInfo in unfoldings and rules]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-In unfoldings and rules, we guarantee that the template is occ-analysed,
-so that the occurrence info on the binders is correct. This is important,
-because the Simplifier does not re-analyse the template when using it. If
-the occurrence info is wrong
- - We may get more simplifier iterations than necessary, because
- once-occ info isn't there
- - More seriously, we may get an infinite loop if there's a Rec
- without a loop breaker marked
+In unfoldings and rules, we guarantee that the template is occ-analysed, so
+that the occurrence info on the binders is correct. That way, when the
+Simplifier inlines an unfolding, it doesn't need to occ-analysis it first.
+(The Simplifier is designed to simplify occ-analysed expressions.)
+
+Given this decision it's vital that we do *always* do it.
+
+* If we don't, we may get more simplifier iterations than necessary,
+ because once-occ info isn't there
+
+* More seriously, we may get an infinite loop if there's a Rec without a
+ loop breaker marked.
+
+* Or we may get code that mentions variables not in scope: #22761
+ e.g. Suppose we have a stable unfolding : \y. let z = p+1 in 3
+ Then the pre-simplifier occ-anal will occ-anal the unfolding
+ (redundantly perhaps, but we need its free vars); this will not report
+ the use of `p`; so p's binding will be discarded, and yet `p` is still
+ mentioned.
+
+ Better to occ-anal the unfolding at birth, which will drop the
+ z-binding as dead code. (Remember, it's the occurrence analyser that
+ drops dead code.)
+
+* Another example is #8892:
+ \x -> letrec { f = ...g...; g* = f } in body
+ where g* is (for some strange reason) the loop breaker. If we don't
+ occ-anal it when reading it in, we won't mark g as a loop breaker, and we
+ may inline g entirely in body, dropping its binding, and leaving the
+ occurrence in f out of scope. This happened in #8892, where the unfolding
+ in question was a DFun unfolding.
************************************************************************
=====================================
compiler/GHC/Core/Opt/Arity.hs
=====================================
@@ -3088,8 +3088,15 @@ etaExpandToJoinPointRule join_arity rule@(Rule { ru_bndrs = bndrs, ru_rhs = rhs
| need_args < 0
= pprPanic "etaExpandToJoinPointRule" (ppr join_arity $$ ppr rule)
| otherwise
- = rule { ru_bndrs = bndrs ++ new_bndrs, ru_args = args ++ new_args
- , ru_rhs = new_rhs }
+ = rule { ru_bndrs = bndrs ++ new_bndrs
+ , ru_args = args ++ new_args
+ , ru_rhs = new_rhs }
+ -- new_rhs really ought to be occ-analysed (see GHC.Core Note
+ -- [OccInfo in unfoldings and rules]), but it makes a module loop to
+ -- do so; it doesn't happen often; and it doesn't really matter if
+ -- the outer binders have bogus occurrence info; and new_rhs won't
+ -- have dead code if rhs didn't.
+
where
need_args = join_arity - length args
(new_bndrs, new_rhs) = etaBodyForJoinPoint need_args rhs
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -2165,6 +2165,17 @@ So we have a fast-path that keeps the old tree if the occ_bs_env is
empty. This just saves a bit of allocation and reconstruction; not
a big deal.
+This fast path exposes a tricky cornder, though (#22761). Supose we have
+ Unfolding = \x. let y = foo in x+1
+which includes a dead binding for `y`. In occAnalUnfolding we occ-anal
+the unfolding and produce /no/ occurrences of `foo` (since `y` is
+dead). But if we discard the occ-analysed syntax tree (which we do on
+our fast path), and use the old one, we still /have/ an occurrence of
+`foo` -- and that can lead to out-of-scope variables (#22761).
+
+Solution: always keep occ-analysed trees in unfoldings and rules, so they
+have no dead code. See Note [OccInfo in unfoldings and rules] in GHC.Core.
+
Note [Cascading inlines]
~~~~~~~~~~~~~~~~~~~~~~~~
By default we use an rhsCtxt for the RHS of a binding. This tells the
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -1065,7 +1065,7 @@ subst_id_bndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst })
-- See Note [Bangs in the Simplifier]
!id1 = uniqAway in_scope old_id
!id2 = substIdType env id1
- !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
+ !id3 = zapFragileIdInfo id2 -- Zaps rules, worker-info, unfolding
-- and fragile OccInfo
!new_id = adjust_type id3
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -319,14 +319,14 @@ simplLazyBind :: SimplEnv
-> TopLevelFlag -> RecFlag
-> InId -> OutId -- Binder, both pre-and post simpl
-- Not a JoinId
- -- The OutId has IdInfo, except arity, unfolding
+ -- The OutId has IdInfo (notably RULES),
+ -- except arity, unfolding
-- Ids only, no TyVars
-> InExpr -> SimplEnv -- The RHS and its environment
-> SimplM (SimplFloats, SimplEnv)
-- Precondition: the OutId is already in the InScopeSet of the incoming 'env'
-- Precondition: not a JoinId
-- Precondition: rhs obeys the let-can-float invariant
--- NOT used for JoinIds
simplLazyBind env top_lvl is_rec bndr bndr1 rhs rhs_se
= assert (isId bndr )
assertPpr (not (isJoinId bndr)) (ppr bndr) $
@@ -398,48 +398,45 @@ simplJoinBind env is_rec cont old_bndr new_bndr rhs rhs_se
; completeBind env (BC_Join is_rec cont) old_bndr new_bndr rhs' }
--------------------------
-simplNonRecX :: SimplEnv
+simplAuxBind :: SimplEnv
-> InId -- Old binder; not a JoinId
-> OutExpr -- Simplified RHS
-> SimplM (SimplFloats, SimplEnv)
--- A specialised variant of simplNonRec used when the RHS is already
--- simplified, notably in knownCon. It uses case-binding where necessary.
+-- A specialised variant of completeBindX used to construct non-recursive
+-- auxiliary bindings, notably in knownCon.
+--
+-- The binder comes from a case expression (case binder or alternative)
+-- and so does not have rules, inline pragmas etc.
--
-- Precondition: rhs satisfies the let-can-float invariant
-simplNonRecX env bndr new_rhs
- | assertPpr (not (isJoinId bndr)) (ppr bndr) $
+simplAuxBind env bndr new_rhs
+ | assertPpr (isId bndr && not (isJoinId bndr)) (ppr bndr) $
isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p }
= return (emptyFloats env, env) -- Here c is dead, and we avoid
- -- creating the binding c = (a,b)
-
- | Coercion co <- new_rhs
- = return (emptyFloats env, extendCvSubst env bndr co)
+ -- creating the binding c = (a,b)
+ -- The cases would be inlined unconditionally by completeBind:
+ -- but it seems not uncommon, and avoids faff to do it here
+ -- This is safe because it's only used for auxiliary bindings, which
+ -- have no NOLINE pragmas, nor RULEs
| exprIsTrivial new_rhs -- Short-cut for let x = y in ...
- -- This case would ultimately land in postInlineUnconditionally
- -- but it seems not uncommon, and avoids a lot of faff to do it here
- = return (emptyFloats env
- , extendIdSubst env bndr (DoneEx new_rhs Nothing))
+ = return ( emptyFloats env
+ , case new_rhs of
+ Coercion co -> extendCvSubst env bndr co
+ _ -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )
| otherwise
- = do { (env1, new_bndr) <- simplBinder env bndr
- ; let is_strict = isStrictId new_bndr
- -- isStrictId: use new_bndr because the InId bndr might not have
- -- a fixed runtime representation, which isStrictId doesn't expect
- -- c.f. Note [Dark corner with representation polymorphism]
-
- ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
- new_bndr (emptyFloats env) new_rhs
- -- NB: it makes a surprisingly big difference (5% in compiler allocation
- -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
- -- because this is simplNonRecX, so bndr is not in scope in the RHS.
-
- ; (bind_float, env2) <- completeBind (env1 `setInScopeFromF` rhs_floats)
- (BC_Let NotTopLevel NonRecursive)
+ = do { -- ANF-ise the RHS
+ let !occ_fs = getOccFS bndr
+ ; (anf_floats, rhs1) <- prepareRhs env NotTopLevel occ_fs new_rhs
+ ; unless (isEmptyLetFloats anf_floats) (tick LetFloatFromLet)
+ ; let rhs_floats = emptyFloats env `addLetFloats` anf_floats
+
+ -- Simplify the binder and complete the binding
+ ; (env1, new_bndr) <- simplBinder (env `setInScopeFromF` rhs_floats) bndr
+ ; (bind_float, env2) <- completeBind env1 (BC_Let NotTopLevel NonRecursive)
bndr new_bndr rhs1
- -- Must pass env1 to completeBind in case simplBinder had to clone,
- -- and extended the substitution with [bndr :-> new_bndr]
; return (rhs_floats `addFloats` bind_float, env2) }
@@ -761,49 +758,54 @@ prepareRhs :: HasDebugCallStack
-- x = Just a
-- See Note [prepareRhs]
prepareRhs env top_lvl occ rhs0
- = do { (_is_exp, floats, rhs1) <- go 0 rhs0
- ; return (floats, rhs1) }
+ | is_expandable = anfise rhs0
+ | otherwise = return (emptyLetFloats, rhs0)
where
- go :: Int -> OutExpr -> SimplM (Bool, LetFloats, OutExpr)
- go n_val_args (Cast rhs co)
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
- ; return (is_exp, floats, Cast rhs' co) }
- go n_val_args (App fun (Type ty))
- = do { (is_exp, floats, rhs') <- go n_val_args fun
- ; return (is_exp, floats, App rhs' (Type ty)) }
- go n_val_args (App fun arg)
- = do { (is_exp, floats1, fun') <- go (n_val_args+1) fun
- ; if is_exp
- then do { (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
- ; return (True, floats1 `addLetFlts` floats2, App fun' arg') }
- else return (False, emptyLetFloats, App fun arg)
- }
- go n_val_args (Var fun)
- = return (is_exp, emptyLetFloats, Var fun)
- where
- is_exp = isExpandableApp fun n_val_args -- The fun a constructor or PAP
- -- See Note [CONLIKE pragma] in GHC.Types.Basic
- -- The definition of is_exp should match that in
- -- 'GHC.Core.Opt.OccurAnal.occAnalApp'
-
- go n_val_args (Tick t rhs)
+ -- We can' use exprIsExpandable because the WHOLE POINT is that
+ -- we want to treat (K <big>) as expandable, because we are just
+ -- about "anfise" the <big> expression. exprIsExpandable would
+ -- just say no!
+ is_expandable = go rhs0 0
+ where
+ go (Var fun) n_val_args = isExpandableApp fun n_val_args
+ go (App fun arg) n_val_args
+ | isTypeArg arg = go fun n_val_args
+ | otherwise = go fun (n_val_args + 1)
+ go (Cast rhs _) n_val_args = go rhs n_val_args
+ go (Tick _ rhs) n_val_args = go rhs n_val_args
+ go _ _ = False
+
+ anfise :: OutExpr -> SimplM (LetFloats, OutExpr)
+ anfise (Cast rhs co)
+ = do { (floats, rhs') <- anfise rhs
+ ; return (floats, Cast rhs' co) }
+ anfise (App fun (Type ty))
+ = do { (floats, rhs') <- anfise fun
+ ; return (floats, App rhs' (Type ty)) }
+ anfise (App fun arg)
+ = do { (floats1, fun') <- anfise fun
+ ; (floats2, arg') <- makeTrivial env top_lvl topDmd occ arg
+ ; return (floats1 `addLetFlts` floats2, App fun' arg') }
+ anfise (Var fun)
+ = return (emptyLetFloats, Var fun)
+
+ anfise (Tick t rhs)
-- We want to be able to float bindings past this
-- tick. Non-scoping ticks don't care.
| tickishScoped t == NoScope
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
- ; return (is_exp, floats, Tick t rhs') }
+ = do { (floats, rhs') <- anfise rhs
+ ; return (floats, Tick t rhs') }
-- On the other hand, for scoping ticks we need to be able to
-- copy them on the floats, which in turn is only allowed if
-- we can obtain non-counting ticks.
| (not (tickishCounts t) || tickishCanSplit t)
- = do { (is_exp, floats, rhs') <- go n_val_args rhs
+ = do { (floats, rhs') <- anfise rhs
; let tickIt (id, expr) = (id, mkTick (mkNoCount t) expr)
floats' = mapLetFloats floats tickIt
- ; return (is_exp, floats', Tick t rhs') }
+ ; return (floats', Tick t rhs') }
- go _ other
- = return (False, emptyLetFloats, other)
+ anfise other = return (emptyLetFloats, other)
makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })
@@ -1244,7 +1246,7 @@ simplExprF1 env (Let (NonRec bndr rhs) body) cont
| otherwise
= {-#SCC "simplNonRecE" #-}
- simplNonRecE env False bndr (rhs, env) body cont
+ simplNonRecE env FromLet bndr (rhs, env) body cont
{- Note [Avoiding space leaks in OutType]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1505,8 +1507,9 @@ rebuild env expr cont
StrictArg { sc_fun = fun, sc_cont = cont, sc_fun_ty = fun_ty }
-> rebuildCall env (addValArgTo fun expr fun_ty ) cont
- StrictBind { sc_bndr = b, sc_body = body, sc_env = se, sc_cont = cont }
- -> completeBindX (se `setInScopeFromE` env) b expr body cont
+ StrictBind { sc_bndr = b, sc_body = body, sc_env = se
+ , sc_cont = cont, sc_from = from_what }
+ -> completeBindX (se `setInScopeFromE` env) from_what b expr body cont
ApplyToTy { sc_arg_ty = ty, sc_cont = cont}
-> rebuild env (App expr (Type ty)) cont
@@ -1518,25 +1521,48 @@ rebuild env expr cont
; rebuild env (App expr arg') cont }
completeBindX :: SimplEnv
+ -> FromWhat
-> InId -> OutExpr -- Bind this Id to this (simplified) expression
-- (the let-can-float invariant may not be satisfied)
- -> InExpr -- In this lambda
+ -> InExpr -- In this body
-> SimplCont -- Consumed by this continuation
-> SimplM (SimplFloats, OutExpr)
-completeBindX env bndr rhs body cont
- | needsCaseBinding (idType bndr) rhs -- Enforcing the let-can-float-invariant
- = do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; (floats, expr') <- simplLam env1 body cont
+completeBindX env from_what bndr rhs body cont
+ | FromBeta arg_ty <- from_what
+ , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr -- Lambda binders don't have rules
+ ; (floats, expr') <- simplNonRecBody env1 from_what body cont
-- Do not float floats past the Case binder below
; let expr'' = wrapFloats floats expr'
- ; let case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']
+ case_expr = Case rhs bndr1 (contResultType cont) [Alt DEFAULT [] expr'']
; return (emptyFloats env, case_expr) }
- | otherwise
- = do { (floats1, env') <- simplNonRecX env bndr rhs
- ; (floats2, expr') <- simplLam env' body cont
- ; return (floats1 `addFloats` floats2, expr') }
+ | otherwise -- Make a let-binding
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+
+ ; let is_strict = isStrictId bndr2
+ -- isStrictId: use simplified binder because the InId bndr might not have
+ -- a fixed runtime representation, which isStrictId doesn't expect
+ -- c.f. Note [Dark corner with representation polymorphism]
+
+ ; (rhs_floats, rhs1) <- prepareBinding env NotTopLevel NonRecursive is_strict
+ bndr2 (emptyFloats env) rhs
+ -- NB: it makes a surprisingly big difference (5% in compiler allocation
+ -- in T9630) to pass 'env' rather than 'env1'. It's fine to pass 'env',
+ -- because this is simplNonRecX, so bndr is not in scope in the RHS.
+
+ ; (bind_float, env2) <- completeBind (env2 `setInScopeFromF` rhs_floats)
+ (BC_Let NotTopLevel NonRecursive)
+ bndr bndr2 rhs1
+ -- Must pass env1 to completeBind in case simplBinder had to clone,
+ -- and extended the substitution with [bndr :-> new_bndr]
+
+ -- Simplify the body
+ ; (body_floats, body') <- simplNonRecBody env2 from_what body cont
+ ; let all_floats = rhs_floats `addFloats` bind_float `addFloats` body_floats
+ ; return ( all_floats, body' ) }
{-
************************************************************************
@@ -1674,6 +1700,14 @@ simplArg env dup_flag fun_ty arg_env arg
************************************************************************
-}
+simplNonRecBody :: SimplEnv -> FromWhat
+ -> InExpr -> SimplCont
+ -> SimplM (SimplFloats, OutExpr)
+simplNonRecBody env from_what body cont
+ = case from_what of
+ FromLet -> simplExprF env body cont
+ FromBeta {} -> simplLam env body cont
+
simplLam :: SimplEnv -> InExpr -> SimplCont
-> SimplM (SimplFloats, OutExpr)
@@ -1690,15 +1724,24 @@ simpl_lam env bndr body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
-- Value beta-reduction
simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se
- , sc_cont = cont, sc_dup = dup })
- | isSimplified dup -- Don't re-simplify if we've simplified it once
- -- See Note [Avoiding exponential behaviour]
+ , sc_cont = cont, sc_dup = dup
+ , sc_hole_ty = fun_ty})
= do { tick (BetaReduction bndr)
- ; completeBindX env bndr arg body cont }
+ ; let arg_ty = funArgTy fun_ty
+ ; if | isSimplified dup -- Don't re-simplify if we've simplified it once
+ -- Including don't preInlineUnconditionally
+ -- See Note [Avoiding exponential behaviour]
+ -> completeBindX env (FromBeta arg_ty) bndr arg body cont
+
+ | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se
+ , not (needsCaseBinding arg_ty arg)
+ -- Ok to test arg::InExpr in needsCaseBinding because
+ -- exprOkForSpeculation is stable under simplification
+ -> do { tick (PreInlineUnconditionally bndr)
+ ; simplLam env' body cont }
- | otherwise -- See Note [Avoiding exponential behaviour]
- = do { tick (BetaReduction bndr)
- ; simplNonRecE env True bndr (arg, arg_se) body cont }
+ | otherwise
+ -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }
-- Discard a non-counting tick on a lambda. This may change the
-- cost attribution slightly (moving the allocation of the
@@ -1730,8 +1773,7 @@ simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs
------------------
simplNonRecE :: SimplEnv
- -> Bool -- True <=> from a lambda
- -- False <=> from a let
+ -> FromWhat
-> InId -- The binder, always an Id
-- Never a join point
-> (InExpr, SimplEnv) -- Rhs of binding (or arg of lambda)
@@ -1740,56 +1782,48 @@ simplNonRecE :: SimplEnv
-> SimplM (SimplFloats, OutExpr)
-- simplNonRecE is used for
--- * non-top-level non-recursive non-join-point lets in expressions
--- * beta reduction
+-- * from=FromLet: a non-top-level non-recursive non-join-point let-expression
+-- * from=FromBeta: a binding arising from a beta reduction
--
--- simplNonRec env b (rhs, rhs_se) body k
+-- simplNonRecE env b (rhs, rhs_se) body k
-- = let env in
-- cont< let b = rhs_se(rhs) in body >
--
-- It deals with strict bindings, via the StrictBind continuation,
-- which may abort the whole process.
--
--- from_lam=False => the RHS satisfies the let-can-float invariant
+-- from_what=FromLet => the RHS satisfies the let-can-float invariant
-- Otherwise it may or may not satisfy it.
-simplNonRecE env from_lam bndr (rhs, rhs_se) body cont
- = assert (isId bndr && not (isJoinId bndr) ) $
- do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; let needs_case_binding = needsCaseBinding (idType bndr1) rhs
- -- See Note [Dark corner with representation polymorphism]
- -- If from_lam=False then needs_case_binding is False,
- -- because the binding started as a let, which must
- -- satisfy let-can-float
-
- ; if | from_lam && not needs_case_binding
- -- If not from_lam we are coming from a (NonRec bndr rhs) binding
- -- and preInlineUnconditionally has been done already;
- -- no need to repeat it. But for lambdas we must be careful about
- -- preInlineUndonditionally: consider (\(x:Int#). 3) (error "urk")
- -- We must not drop the (error "urk").
- , Just env' <- preInlineUnconditionally env NotTopLevel bndr rhs rhs_se
- -> do { tick (PreInlineUnconditionally bndr)
- ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $
- simplLam env' body cont }
-
- -- Deal with strict bindings
- | isStrictId bndr1 && seCaseCase env
- || from_lam && needs_case_binding
- -- The important bit here is needs_case_binds; but no need to
- -- test it if from_lam is False because then needs_case_binding is False too
- -- NB: either way, the RHS may or may not satisfy let-can-float
- -- but that's ok for StrictBind.
- -> simplExprF (rhs_se `setInScopeFromE` env) rhs
- (StrictBind { sc_bndr = bndr, sc_body = body
- , sc_env = env, sc_cont = cont, sc_dup = NoDup })
-
- -- Deal with lazy bindings
- | otherwise
- -> do { (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
- ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se
- ; (floats2, expr') <- simplLam env3 body cont
- ; return (floats1 `addFloats` floats2, expr') } }
+simplNonRecE env from_what bndr (rhs, rhs_se) body cont
+ | assert (isId bndr && not (isJoinId bndr) ) $
+ is_strict_bind
+ = -- Evaluate RHS strictly
+ simplExprF (rhs_se `setInScopeFromE` env) rhs
+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
+ , sc_env = env, sc_cont = cont, sc_dup = NoDup })
+
+ | otherwise -- Evaluate RHS lazily
+ = do { (env1, bndr1) <- simplNonRecBndr env bndr
+ ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+ ; (floats1, env3) <- simplLazyBind env2 NotTopLevel NonRecursive
+ bndr bndr2 rhs rhs_se
+ ; (floats2, expr') <- simplNonRecBody env3 from_what body cont
+ ; return (floats1 `addFloats` floats2, expr') }
+
+ where
+ is_strict_bind = case from_what of
+ FromBeta arg_ty | isUnliftedType arg_ty -> True
+ -- If we are coming from a beta-reduction (FromBeta) we must
+ -- establish the let-can-float invariant, so go via StrictBind
+ -- If not, the invariant holds already, and it's optional.
+ -- Using arg_ty: see Note [Dark corner with representation polymorphism]
+ -- e.g (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg
+ -- When we come to `x=arg` we myst choose lazy/strict correctly
+ -- It's wrong to err in either directly
+
+ _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)
+
------------------
simplRecE :: SimplEnv
@@ -1835,7 +1869,7 @@ Note [Avoiding exponential behaviour]
One way in which we can get exponential behaviour is if we simplify a
big expression, and then re-simplify it -- and then this happens in a
deeply-nested way. So we must be jolly careful about re-simplifying
-an expression. That is why simplNonRecX does not try
+an expression (#13379). That is why simplNonRecX does not try
preInlineUnconditionally (unlike simplNonRecE).
Example:
@@ -2618,15 +2652,10 @@ Is this inefficient? Not really: we are about to walk over the result
of the rule firing to simplify it, so occurrence analysis is at most
a constant factor.
-Possible improvement: occ-anal the rules when putting them in the
-database; and in the simplifier just occ-anal the OutExpr arguments.
-But that's more complicated and the rule RHS is usually tiny; so I'm
-just doing the simple thing.
-
-Historical note: previously we did occ-anal the rules in Rule.hs,
-but failed to occ-anal the OutExpr arguments, which led to the
-nasty performance problem described above.
-
+Note, however, that the rule RHS is /already/ occ-analysed; see
+Note [OccInfo in unfoldings and rules] in GHC.Core. There is something
+unsatisfactory about doing it twice; but the rule RHS is usually very
+small, and this is simple.
Note [Optimising tagToEnum#]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -2930,7 +2959,7 @@ rebuildCase env scrut case_bndr alts cont
where
simple_rhs env wfloats case_bndr_rhs bs rhs =
assert (null bs) $
- do { (floats1, env') <- simplNonRecX env case_bndr case_bndr_rhs
+ do { (floats1, env') <- simplAuxBind env case_bndr case_bndr_rhs
-- scrut is a constructor application,
-- hence satisfies let-can-float invariant
; (floats2, expr') <- simplExprF env' rhs cont
@@ -2997,7 +3026,7 @@ rebuildCase env scrut case_bndr alts@[Alt _ bndrs rhs] cont
| all_dead_bndrs
, doCaseToLet scrut case_bndr
= do { tick (CaseElim case_bndr)
- ; (floats1, env') <- simplNonRecX env case_bndr scrut
+ ; (floats1, env') <- simplAuxBind env case_bndr scrut
; (floats2, expr') <- simplExprF env' rhs cont
; return (floats1 `addFloats` floats2, expr') }
@@ -3483,12 +3512,11 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
bind_args env' (b:bs') (arg : args)
= assert (isId b) $
do { let b' = zap_occ b
- -- Note that the binder might be "dead", because it doesn't
- -- occur in the RHS; and simplNonRecX may therefore discard
- -- it via postInlineUnconditionally.
+ -- zap_occ: the binder might be "dead", because it doesn't
+ -- occur in the RHS; and simplAuxBind may therefore discard it.
-- Nevertheless we must keep it if the case-binder is alive,
-- because it may be used in the con_app. See Note [knownCon occ info]
- ; (floats1, env2) <- simplNonRecX env' b' arg -- arg satisfies let-can-float invariant
+ ; (floats1, env2) <- simplAuxBind env' b' arg -- arg satisfies let-can-float invariant
; (floats2, env3) <- bind_args env2 bs' args
; return (floats1 `addFloats` floats2, env3) }
@@ -3514,7 +3542,7 @@ knownCon env scrut dc_floats dc dc_ty_args dc_args bndr bs rhs cont
; let con_app = Var (dataConWorkId dc)
`mkTyApps` dc_ty_args
`mkApps` dc_args
- ; simplNonRecX env bndr con_app }
+ ; simplAuxBind env bndr con_app }
-------------------
missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont
@@ -3621,15 +3649,15 @@ mkDupableContWithDmds env dmds (TickIt t cont)
; return (floats, TickIt t cont') }
mkDupableContWithDmds env _
- (StrictBind { sc_bndr = bndr, sc_body = body
+ (StrictBind { sc_bndr = bndr, sc_body = body, sc_from = from_what
, sc_env = se, sc_cont = cont})
-- See Note [Duplicating StrictBind]
-- K[ let x = <> in b ] --> join j x = K[ b ]
-- j <>
= do { let sb_env = se `setInScopeFromE` env
; (sb_env1, bndr') <- simplBinder sb_env bndr
- ; (floats1, join_inner) <- simplLam sb_env1 body cont
- -- No need to use mkDupableCont before simplLam; we
+ ; (floats1, join_inner) <- simplNonRecBody sb_env1 from_what body cont
+ -- No need to use mkDupableCont before simplNonRecBody; we
-- use cont once here, and then share the result if necessary
; let join_body = wrapFloats floats1 join_inner
@@ -3757,6 +3785,7 @@ mkDupableStrictBind env arg_bndr join_rhs res_ty
, StrictBind { sc_bndr = arg_bndr
, sc_body = join_rhs
, sc_env = zapSubstEnv env
+ , sc_from = FromLet
-- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
, sc_dup = OkToDup
, sc_cont = mkBoringStop res_ty } )
@@ -4430,7 +4459,9 @@ simplRules env mb_new_id rules bind_cxt
; return (rule { ru_bndrs = bndrs'
, ru_fn = fn_name'
, ru_args = args'
- , ru_rhs = rhs' }) }
+ , ru_rhs = occurAnalyseExpr rhs' }) }
+ -- Remember to occ-analyse, to drop dead code.
+ -- See Note [OccInfo in unfoldings and rules] in GHC.Core
{- Note [Simplifying the RHS of a RULE]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -21,7 +21,7 @@ module GHC.Core.Opt.Simplify.Utils (
BindContext(..), bindContextLevel,
-- The continuation type
- SimplCont(..), DupFlag(..), StaticEnv,
+ SimplCont(..), DupFlag(..), FromWhat(..), StaticEnv,
isSimplified, contIsStop,
contIsDupable, contResultType, contHoleType, contHoleScaling,
contIsTrivial, contArgs, contIsRhs,
@@ -192,6 +192,7 @@ data SimplCont
-- or, equivalently, = K[ (\x.b) e ]
{ sc_dup :: DupFlag -- See Note [DupFlag invariants]
, sc_bndr :: InId
+ , sc_from :: FromWhat
, sc_body :: InExpr
, sc_env :: StaticEnv -- See Note [StaticEnv invariant]
, sc_cont :: SimplCont }
@@ -213,6 +214,8 @@ data SimplCont
type StaticEnv = SimplEnv -- Just the static part is relevant
+data FromWhat = FromLet | FromBeta OutType
+
-- See Note [DupFlag invariants]
data DupFlag = NoDup -- Unsimplified, might be big
| Simplified -- Simplified
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -63,6 +63,7 @@ import GHC.Core.Tidy ( tidyRules )
import GHC.Core.Map.Expr ( eqCoreExpr )
import GHC.Core.Opt.Arity( etaExpandToJoinPointRule )
import GHC.Core.Make ( mkCoreLams )
+import GHC.Core.Opt.OccurAnal( occurAnalyseExpr )
import GHC.Tc.Utils.TcType ( tcSplitTyConApp_maybe )
import GHC.Builtin.Types ( anyTypeOfKind )
@@ -189,13 +190,18 @@ mkRule :: Module -> Bool -> Bool -> RuleName -> Activation
-- ^ Used to make 'CoreRule' for an 'Id' defined in the module being
-- compiled. See also 'GHC.Core.CoreRule'
mkRule this_mod is_auto is_local name act fn bndrs args rhs
- = Rule { ru_name = name, ru_fn = fn, ru_act = act,
- ru_bndrs = bndrs, ru_args = args,
- ru_rhs = rhs,
- ru_rough = roughTopNames args,
- ru_origin = this_mod,
- ru_orphan = orph,
- ru_auto = is_auto, ru_local = is_local }
+ = Rule { ru_name = name
+ , ru_act = act
+ , ru_fn = fn
+ , ru_bndrs = bndrs
+ , ru_args = args
+ , ru_rhs = occurAnalyseExpr rhs
+ -- See Note [OccInfo in unfoldings and rules]
+ , ru_rough = roughTopNames args
+ , ru_origin = this_mod
+ , ru_orphan = orph
+ , ru_auto = is_auto
+ , ru_local = is_local }
where
-- Compute orphanhood. See Note [Orphans] in GHC.Core.InstEnv
-- A rule is an orphan only if none of the variables
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -513,8 +513,8 @@ bindNonRec bndr rhs body
-- | Tests whether we have to use a @case@ rather than @let@ binding for this
-- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant"
needsCaseBinding :: Type -> CoreExpr -> Bool
-needsCaseBinding ty rhs =
- mightBeUnliftedType ty && not (exprOkForSpeculation rhs)
+needsCaseBinding ty rhs
+ = mightBeUnliftedType ty && not (exprOkForSpeculation rhs)
-- Make a case expression instead of a let
-- These can arise either from the desugarer,
-- or from beta reductions: (\x.e) (x +# y)
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -517,6 +517,12 @@ data DynFlags = DynFlags {
reductionDepth :: IntWithInf, -- ^ Typechecker maximum stack depth
solverIterations :: IntWithInf, -- ^ Number of iterations in the constraints solver
-- Typically only 1 is needed
+ givensFuel :: Int, -- ^ Number of layers of superclass expansion
+ -- Should be < solverIterations
+ wantedsFuel :: Int, -- ^ Number of layers of superclass expansion
+ -- Should be < givensFuel
+ qcsFuel :: Int, -- ^ Number of layers of superclass expansion
+ -- Should be < givensFuel
homeUnitId_ :: UnitId, -- ^ Target home unit-id
homeUnitInstanceOf_ :: Maybe UnitId, -- ^ Id of the unit to instantiate
@@ -1148,6 +1154,9 @@ defaultDynFlags mySettings =
mainFunIs = Nothing,
reductionDepth = treatZeroAsInf mAX_REDUCTION_DEPTH,
solverIterations = treatZeroAsInf mAX_SOLVER_ITERATIONS,
+ givensFuel = mAX_GIVENS_FUEL,
+ wantedsFuel = mAX_WANTEDS_FUEL,
+ qcsFuel = mAX_QC_FUEL,
homeUnitId_ = mainUnitId,
homeUnitInstanceOf_ = Nothing,
@@ -2732,6 +2741,12 @@ dynamic_flags_deps = [
(intSuffix (\n d -> d { reductionDepth = treatZeroAsInf n }))
, make_ord_flag defFlag "fconstraint-solver-iterations"
(intSuffix (\n d -> d { solverIterations = treatZeroAsInf n }))
+ , make_ord_flag defFlag "fgivens-expansion-fuel"
+ (intSuffix (\n d -> d { givensFuel = n }))
+ , make_ord_flag defFlag "fwanteds-expansion-fuel"
+ (intSuffix (\n d -> d { wantedsFuel = n }))
+ , make_ord_flag defFlag "fqcs-expansion-fuel"
+ (intSuffix (\n d -> d { qcsFuel = n }))
, (Deprecated, defFlag "fcontext-stack"
(intSuffixM (\n d ->
do { deprecate $ "use -freduction-depth=" ++ show n ++ " instead"
@@ -4939,6 +4954,7 @@ needSourceNotes dflags = debugLevel dflags > 0
-- LinkerInfo contains any extra options needed by the system linker.
data LinkerInfo
= GnuLD [Option]
+ | Mold [Option]
| GnuGold [Option]
| LlvmLLD [Option]
| DarwinLD [Option]
=====================================
compiler/GHC/Settings/Constants.hs
=====================================
@@ -30,6 +30,21 @@ mAX_REDUCTION_DEPTH = 200
mAX_SOLVER_ITERATIONS :: Int
mAX_SOLVER_ITERATIONS = 4
+-- | In case of loopy quantified costraints constraints,
+-- how many times should we allow superclass expansions
+mAX_QC_FUEL :: Int
+mAX_QC_FUEL = 3
+
+-- | In case of loopy wanted constraints,
+-- how many times should we allow superclass expansions
+mAX_WANTEDS_FUEL :: Int
+mAX_WANTEDS_FUEL = 1
+
+-- | In case of loopy given constraints,
+-- how many times should we allow superclass expansions
+mAX_GIVENS_FUEL :: Int
+mAX_GIVENS_FUEL = 3
+
wORD64_SIZE :: Int
wORD64_SIZE = 8
=====================================
compiler/GHC/SysTools/Info.hs
=====================================
@@ -70,6 +70,7 @@ The flag is only needed on ELF systems. On Windows (PE) and Mac OS X
neededLinkArgs :: LinkerInfo -> [Option]
neededLinkArgs (GnuLD o) = o
+neededLinkArgs (Mold o) = o
neededLinkArgs (GnuGold o) = o
neededLinkArgs (LlvmLLD o) = o
neededLinkArgs (DarwinLD o) = o
@@ -106,6 +107,10 @@ getLinkerInfo' logger dflags = do
-- see Note [ELF needed shared libs]
"-Wl,--no-as-needed"])
+ | any ("mold" `isPrefixOf`) stdo =
+ return (Mold $ map Option [ --see Note [ELF needed shared libs]
+ "-Wl,--no-as-needed"])
+
| any ("GNU gold" `isPrefixOf`) stdo =
-- GNU gold only needs --no-as-needed. #10110.
-- ELF specific flag, see Note [ELF needed shared libs]
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -2338,6 +2338,10 @@ maybe_simplify_again n limit unif_happened wc@(WC { wc_simple = simples })
do { new_given <- makeSuperClasses pending_given
; new_wanted <- makeSuperClasses pending_wanted
; solveSimpleGivens new_given -- Add the new Givens to the inert set
+ ; traceTcS "maybe_simplify_again" (vcat [ text "pending_given" <+> ppr pending_given
+ , text "new_given" <+> ppr new_given
+ , text "pending_wanted" <+> ppr pending_wanted
+ , text "new_wanted" <+> ppr new_wanted ])
; simplify_loop n limit (not (null pending_given)) $
wc { wc_simple = simples1 `unionBags` listToBag new_wanted } } }
-- (not (null pending_given)): see Note [Superclass iteration]
@@ -2366,6 +2370,43 @@ superclasses. In that case we check whether the new Wanteds actually led to
any new unifications, and iterate the implications only if so.
-}
+{- Note [SimplifyInfer with UndecidableSuperClasses]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+In some cases while infering the type of a term well typed term, it is necessary to ensure
+we limit the wanted superclass expansions.
+Expanding them too many times will lead to the given constraint superclass expansion
+not being able solve all the wanted constraints, by entering a perpetual loop and erroring out on
+too many solver iterations. Expanding them too little will not give us a simplified type signature.
+
+Consider the program (T21909)
+
+ class C [a] => C a where
+ foo :: a -> Int
+
+ bar :: C a => a -> Int
+ bar x = foolocal x
+ where
+ foolocal x = foo x
+
+In the current implimentation
+We infer the type of foolocal to be `(C a) => a -> Int`
+and then simplify it to `(C a, C [[a]]) => a -> Int`
+
+This indeed is not simplification per say, but we are in UndecidableSuperclass case
+so we cannot guarantee simplification of contraints. What we aim for is for the
+the solver to not to loop unnecessarily generating more wanted constraints than
+in can solve in `maybe_simplify_again`.
+
+If we did not limit the wanteds superclass expansion we would simplify the type signature of
+foolocal as `(C a , C [[a]], C[[[[a]]]], C[[[[a]]]], C [[[[[[[[a]]]]]]]]) => a -> Int`
+Definitely _worse_ than above type!
+
+The current limit the expansion of such recursive wanted constraints to 1 (mAX_WANTEDS_FUEL),
+and limit the expansion of recursive given constraints to 3 (mAX_GIVENS_FUEL).
+
+-}
+
+
solveNestedImplications :: Bag Implication
-> TcS (Bag Implication)
-- Precondition: the TcS inerts may contain unsolved simples which have
=====================================
compiler/GHC/Tc/Solver/Canonical.hs
=====================================
@@ -58,7 +58,7 @@ import Control.Monad
import Data.Maybe ( isJust, isNothing )
import Data.List ( zip4 )
import GHC.Types.Basic
-
+import GHC.Driver.Session ( DynFlags, givensFuel, wantedsFuel, qcsFuel )
import qualified Data.Semigroup as S
import Data.Bifunctor ( bimap )
@@ -127,14 +127,16 @@ canonicalize (CEqCan { cc_ev = ev
canNC :: CtEvidence -> TcS (StopOrContinue Ct)
canNC ev =
case classifyPredType pred of
- ClassPred cls tys -> do traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
- canClassNC ev cls tys
+ ClassPred cls tys -> do dflags <- getDynFlags
+ traceTcS "canEvNC:cls" (ppr cls <+> ppr tys)
+ canClassNC dflags ev cls tys
EqPred eq_rel ty1 ty2 -> do traceTcS "canEvNC:eq" (ppr ty1 $$ ppr ty2)
canEqNC ev eq_rel ty1 ty2
IrredPred {} -> do traceTcS "canEvNC:irred" (ppr pred)
canIrred ev
- ForAllPred tvs th p -> do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
+ ForAllPred tvs th p -> do dflags <- getDynFlags
+ traceTcS "canEvNC:forall" (ppr pred)
+ canForAllNC dflags ev tvs th p
where
pred = ctEvPred ev
@@ -147,15 +149,16 @@ canNC ev =
************************************************************************
-}
-canClassNC :: CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
+canClassNC :: DynFlags -> CtEvidence -> Class -> [Type] -> TcS (StopOrContinue Ct)
-- "NC" means "non-canonical"; that is, we have got here
-- from a NonCanonical constraint, not from a CDictCan
-- Precondition: EvVar is class evidence
-canClassNC ev cls tys
+canClassNC dflags ev cls tys
| isGiven ev -- See Note [Eagerly expand given superclasses]
- = do { sc_cts <- mkStrictSuperClasses ev [] [] cls tys
+ = do { let gf = givensFuel dflags
+ ; sc_cts <- mkStrictSuperClasses gf ev [] [] cls tys
; emitWork sc_cts
- ; canClass ev cls tys False }
+ ; canClass ev cls tys doNotExpand }
| CtWanted { ctev_rewriters = rewriters } <- ev
, Just ip_name <- isCallStackPred cls tys
@@ -181,14 +184,16 @@ canClassNC ev cls tys
(ctLocSpan loc) (ctEvExpr new_ev)
; solveCallStack ev ev_cs
- ; canClass new_ev cls tys False -- No superclasses
+ ; canClass new_ev cls tys doNotExpand -- No superclasses
}
| otherwise
- = canClass ev cls tys (has_scs cls)
+ = canClass ev cls tys fuel
where
- has_scs cls = not (null (classSCTheta cls))
+ fuel | cls_has_scs = wantedsFuel dflags
+ | otherwise = doNotExpand
+ cls_has_scs = not (null (classSCTheta cls))
loc = ctEvLoc ev
orig = ctLocOrigin loc
pred = ctEvPred ev
@@ -205,7 +210,7 @@ solveCallStack ev ev_cs = do
canClass :: CtEvidence
-> Class -> [Type]
- -> Bool -- True <=> un-explored superclasses
+ -> ExpansionFuel -- n > 0 <=> un-explored superclasses
-> TcS (StopOrContinue Ct)
-- Precondition: EvVar is class evidence
@@ -492,39 +497,40 @@ makeSuperClasses :: [Ct] -> TcS [Ct]
-- class C [a] => D a
-- makeSuperClasses (C x) will return (D x, C [x])
--
--- NB: the incoming constraints have had their cc_pend_sc flag already
--- flipped to False, by isPendingScDict, so we are /obliged/ to at
--- least produce the immediate superclasses
+-- NB: the incoming constraints will be expanded only if the fuel is striclty > 0
+-- expansion will consume a unit of fuel
makeSuperClasses cts = concatMapM go cts
where
- go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys })
- = mkStrictSuperClasses ev [] [] cls tys
- go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev }))
+ go (CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys, cc_pend_sc = fuel })
+ = assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses (consumeFuel fuel) ev [] [] cls tys
+ go (CQuantCan (QCI { qci_pred = pred, qci_ev = ev, qci_pend_sc = fuel }))
= assertPpr (isClassPred pred) (ppr pred) $ -- The cts should all have
-- class pred heads
- mkStrictSuperClasses ev tvs theta cls tys
+ assertPpr (fuel > 0) (ppr cls) $ -- fuel needs to be more than 0 always
+ mkStrictSuperClasses (consumeFuel fuel) ev tvs theta cls tys
where
(tvs, theta, cls, tys) = tcSplitDFunTy (ctEvPred ev)
go ct = pprPanic "makeSuperClasses" (ppr ct)
mkStrictSuperClasses
- :: CtEvidence
+ :: ExpansionFuel -> CtEvidence
-> [TyVar] -> ThetaType -- These two args are non-empty only when taking
-- superclasses of a /quantified/ constraint
-> Class -> [Type] -> TcS [Ct]
-- Return constraints for the strict superclasses of
-- ev :: forall as. theta => cls tys
-mkStrictSuperClasses ev tvs theta cls tys
- = mk_strict_superclasses (unitNameSet (className cls))
+mkStrictSuperClasses fuel ev tvs theta cls tys
+ = mk_strict_superclasses fuel (unitNameSet (className cls))
ev tvs theta cls tys
-mk_strict_superclasses :: NameSet -> CtEvidence
+mk_strict_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType
-> Class -> [Type] -> TcS [Ct]
-- Always return the immediate superclasses of (cls tys);
-- and expand their superclasses, provided none of them are in rec_clss
-- nor are repeated
-mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
+mk_strict_superclasses fuel rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
tvs theta cls tys
= concatMapM do_one_given $
classSCSelIds cls
@@ -542,7 +548,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
| otherwise
= do { given_ev <- newGivenEvVar sc_loc $
mk_given_desc sel_id sc_pred
- ; mk_superclasses rec_clss given_ev tvs theta sc_pred }
+ ; mk_superclasses fuel rec_clss given_ev tvs theta sc_pred }
where
sc_pred = classMethodInstTy sel_id tys
@@ -603,7 +609,7 @@ mk_strict_superclasses rec_clss (CtGiven { ctev_evar = evar, ctev_loc = loc })
newly_blocked (InstSkol _ head_size) = isJust (this_size `ltPatersonSize` head_size)
newly_blocked _ = False
-mk_strict_superclasses rec_clss ev tvs theta cls tys
+mk_strict_superclasses fuel rec_clss ev tvs theta cls tys
| all noFreeVarsOfType tys
= return [] -- Wanteds with no variables yield no superclass constraints.
-- See Note [Improvement from Ground Wanteds]
@@ -618,7 +624,7 @@ mk_strict_superclasses rec_clss ev tvs theta cls tys
do_one sc_pred
= do { traceTcS "mk_strict_superclasses Wanted" (ppr (mkClassPred cls tys) $$ ppr sc_pred)
; sc_ev <- newWantedNC loc (ctEvRewriters ev) sc_pred
- ; mk_superclasses rec_clss sc_ev [] [] sc_pred }
+ ; mk_superclasses fuel rec_clss sc_ev [] [] sc_pred }
{- Note [Improvement from Ground Wanteds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -633,46 +639,49 @@ dependencies. See Note [Why adding superclasses can help] above.
But no variables means no improvement; case closed.
-}
-mk_superclasses :: NameSet -> CtEvidence
+mk_superclasses :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType -> PredType -> TcS [Ct]
-- Return this constraint, plus its superclasses, if any
-mk_superclasses rec_clss ev tvs theta pred
+mk_superclasses fuel rec_clss ev tvs theta pred
| ClassPred cls tys <- classifyPredType pred
- = mk_superclasses_of rec_clss ev tvs theta cls tys
+ = mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| otherwise -- Superclass is not a class predicate
= return [mkNonCanonical ev]
-mk_superclasses_of :: NameSet -> CtEvidence
+mk_superclasses_of :: ExpansionFuel -> NameSet -> CtEvidence
-> [TyVar] -> ThetaType -> Class -> [Type]
-> TcS [Ct]
-- Always return this class constraint,
-- and expand its superclasses
-mk_superclasses_of rec_clss ev tvs theta cls tys
+mk_superclasses_of fuel rec_clss ev tvs theta cls tys
| loop_found = do { traceTcS "mk_superclasses_of: loop" (ppr cls <+> ppr tys)
- ; return [this_ct] } -- cc_pend_sc of this_ct = True
+ ; return [this_ct] } -- cc_pend_sc of this_ct = fuel
| otherwise = do { traceTcS "mk_superclasses_of" (vcat [ ppr cls <+> ppr tys
, ppr (isCTupleClass cls)
, ppr rec_clss
])
- ; sc_cts <- mk_strict_superclasses rec_clss' ev tvs theta cls tys
+ ; sc_cts <- mk_strict_superclasses fuel rec_clss' ev tvs theta cls tys
; return (this_ct : sc_cts) }
- -- cc_pend_sc of this_ct = False
+ -- cc_pend_sc of this_ct = doNotExpand
where
cls_nm = className cls
loop_found = not (isCTupleClass cls) && cls_nm `elemNameSet` rec_clss
-- Tuples never contribute to recursion, and can be nested
rec_clss' = rec_clss `extendNameSet` cls_nm
+ this_cc_pend | loop_found = fuel
+ | otherwise = 0
+
this_ct | null tvs, null theta
= CDictCan { cc_ev = ev, cc_class = cls, cc_tyargs = tys
- , cc_pend_sc = loop_found }
+ , cc_pend_sc = this_cc_pend }
-- NB: If there is a loop, we cut off, so we have not
-- added the superclasses, hence cc_pend_sc = True
| otherwise
= CQuantCan (QCI { qci_tvs = tvs, qci_pred = mkClassPred cls tys
, qci_ev = ev
- , qci_pend_sc = loop_found })
+ , qci_pend_sc = this_cc_pend })
{- Note [Equality superclasses in quantified constraints]
@@ -723,6 +732,7 @@ canIrred :: CtEvidence -> TcS (StopOrContinue Ct)
-- Precondition: ty not a tuple and no other evidence form
canIrred ev
= do { let pred = ctEvPred ev
+ ; dflags <- getDynFlags
; traceTcS "can_pred" (text "IrredPred = " <+> ppr pred)
; (redn, rewriters) <- rewrite ev pred
; rewriteEvidence rewriters ev redn `andWhenContinue` \ new_ev ->
@@ -731,7 +741,7 @@ canIrred ev
-- Code is like the canNC, except
-- that the IrredPred branch stops work
; case classifyPredType (ctEvPred new_ev) of
- ClassPred cls tys -> canClassNC new_ev cls tys
+ ClassPred cls tys -> canClassNC dflags new_ev cls tys
EqPred eq_rel ty1 ty2 -> -- IrredPreds have kind Constraint, so
-- cannot become EqPreds
pprPanic "canIrred: EqPred"
@@ -740,7 +750,7 @@ canIrred ev
-- should never leave a meta-var filled
-- in with a polytype. This is #18987.
do traceTcS "canEvNC:forall" (ppr pred)
- canForAllNC ev tvs th p
+ canForAllNC dflags ev tvs th p
IrredPred {} -> continueWith $
mkIrredCt IrredShapeReason new_ev } }
@@ -822,24 +832,28 @@ type signature.
-}
-canForAllNC :: CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
+canForAllNC :: DynFlags -> CtEvidence -> [TyVar] -> TcThetaType -> TcPredType
-> TcS (StopOrContinue Ct)
-canForAllNC ev tvs theta pred
+canForAllNC dflags ev tvs theta pred
| isGiven ev -- See Note [Eagerly expand given superclasses]
, Just (cls, tys) <- cls_pred_tys_maybe
- = do { sc_cts <- mkStrictSuperClasses ev tvs theta cls tys
+ = do { let gf = givensFuel dflags
+ ; sc_cts <- mkStrictSuperClasses gf ev tvs theta cls tys
; emitWork sc_cts
- ; canForAll ev False }
+ ; canForAll ev doNotExpand }
| otherwise
- = canForAll ev (isJust cls_pred_tys_maybe)
+ = do { let qcf = qcsFuel dflags
+ fuel | isJust cls_pred_tys_maybe = qcf
+ | otherwise = doNotExpand
+ ; canForAll ev fuel }
where
cls_pred_tys_maybe = getClassPredTys_maybe pred
-canForAll :: CtEvidence -> Bool -> TcS (StopOrContinue Ct)
+canForAll :: CtEvidence -> ExpansionFuel -> TcS (StopOrContinue Ct)
-- We have a constraint (forall as. blah => C tys)
-canForAll ev pend_sc
+canForAll ev fuel
= do { -- First rewrite it to apply the current substitution
let pred = ctEvPred ev
; (redn, rewriters) <- rewrite ev pred
@@ -849,14 +863,14 @@ canForAll ev pend_sc
-- (It takes a lot less code to rewrite before decomposing.)
; case classifyPredType (ctEvPred new_ev) of
ForAllPred tvs theta pred
- -> solveForAll new_ev tvs theta pred pend_sc
+ -> solveForAll new_ev tvs theta pred fuel
_ -> pprPanic "canForAll" (ppr new_ev)
} }
-solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> Bool
+solveForAll :: CtEvidence -> [TyVar] -> TcThetaType -> PredType -> ExpansionFuel
-> TcS (StopOrContinue Ct)
solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
- tvs theta pred _pend_sc
+ tvs theta pred _fuel
= -- See Note [Solving a Wanted forall-constraint]
setLclEnv (ctLocEnv loc) $
-- This setLclEnv is important: the emitImplicationTcS uses that
@@ -902,12 +916,12 @@ solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_lo
_ -> pSizeType pred
-- See Note [Solving a Given forall-constraint]
-solveForAll ev@(CtGiven {}) tvs _theta pred pend_sc
+solveForAll ev@(CtGiven {}) tvs _theta pred fuel
= do { addInertForAll qci
; stopWith ev "Given forall-constraint" }
where
qci = QCI { qci_ev = ev, qci_tvs = tvs
- , qci_pred = pred, qci_pend_sc = pend_sc }
+ , qci_pred = pred, qci_pend_sc = fuel }
{- Note [Solving a Wanted forall-constraint]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -513,10 +513,13 @@ getInertGivens
; return (filter isGivenCt all_cts) }
getPendingGivenScs :: TcS [Ct]
--- Find all inert Given dictionaries, or quantified constraints,
--- whose cc_pend_sc flag is True
--- and that belong to the current level
--- Set their cc_pend_sc flag to False in the inert set, and return that Ct
+-- Find all inert Given dictionaries, or quantified constraints, such that
+-- 1. cc_pend_sc flag has fuel strictly > 0
+-- 2. belongs to the current level
+-- For each such dictionary:
+-- * Return it (with unmodified cc_pend_sc) in sc_pending
+-- * Modify the dict in the inert set to have cc_pend_sc = doNotExpand
+-- to record that we have expanded superclasses for this dict
getPendingGivenScs = do { lvl <- getTcLevel
; updRetInertCans (get_sc_pending lvl) }
@@ -530,29 +533,33 @@ get_sc_pending this_lvl ic@(IC { inert_dicts = dicts, inert_insts = insts })
sc_pending = sc_pend_insts ++ sc_pend_dicts
sc_pend_dicts = foldDicts get_pending dicts []
- dicts' = foldr add dicts sc_pend_dicts
+ dicts' = foldr exhaustAndAdd dicts sc_pend_dicts
(sc_pend_insts, insts') = mapAccumL get_pending_inst [] insts
- get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc = True
- -- but flipping the flag
+ get_pending :: Ct -> [Ct] -> [Ct] -- Get dicts with cc_pend_sc > 0
get_pending dict dicts
- | Just dict' <- pendingScDict_maybe dict
+ | isPendingScDict dict
, belongs_to_this_level (ctEvidence dict)
- = dict' : dicts
+ = dict : dicts
| otherwise
= dicts
- add :: Ct -> DictMap Ct -> DictMap Ct
- add ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
- = addDict dicts cls tys ct
- add ct _ = pprPanic "getPendingScDicts" (ppr ct)
+ exhaustAndAdd :: Ct -> DictMap Ct -> DictMap Ct
+ exhaustAndAdd ct@(CDictCan { cc_class = cls, cc_tyargs = tys }) dicts
+ -- exhaust the fuel for this constraint before adding it as
+ -- we don't want to expand these constraints again
+ = addDict dicts cls tys (ct {cc_pend_sc = doNotExpand})
+ exhaustAndAdd ct _ = pprPanic "getPendingScDicts" (ppr ct)
get_pending_inst :: [Ct] -> QCInst -> ([Ct], QCInst)
get_pending_inst cts qci@(QCI { qci_ev = ev })
| Just qci' <- pendingScInst_maybe qci
, belongs_to_this_level ev
- = (CQuantCan qci' : cts, qci')
+ = (CQuantCan qci : cts, qci')
+ -- qci' have their fuel exhausted
+ -- we don't want to expand these constraints again
+ -- qci is expanded
| otherwise
= (cts, qci)
=====================================
compiler/GHC/Tc/Types/Constraint.hs
=====================================
@@ -11,6 +11,7 @@ module GHC.Tc.Types.Constraint (
-- Canonical constraints
Xi, Ct(..), Cts,
+ ExpansionFuel, doNotExpand, consumeFuel,
emptyCts, andCts, andManyCts, pprCts,
singleCt, listToCts, ctsElts, consCts, snocCts, extendCtsList,
isEmptyCts,
@@ -138,8 +139,6 @@ import Data.Word ( Word8 )
import Data.List ( intersperse )
-
-
{-
************************************************************************
* *
@@ -191,6 +190,16 @@ type Xi = TcType
type Cts = Bag Ct
+-- | Says how many layers of superclasses can we expand.
+-- see Note [SimplifyInfer with UndecidableSuperClasses]
+type ExpansionFuel = Int
+
+doNotExpand :: ExpansionFuel -- Do not expand superclasses anymore
+doNotExpand = 0
+
+consumeFuel :: ExpansionFuel -> ExpansionFuel
+consumeFuel fuel = fuel - 1
+
data Ct
-- Atomic canonical constraints
= CDictCan { -- e.g. Num ty
@@ -199,11 +208,11 @@ data Ct
cc_class :: Class,
cc_tyargs :: [Xi], -- cc_tyargs are rewritten w.r.t. inerts, so Xi
- cc_pend_sc :: Bool
+ cc_pend_sc :: ExpansionFuel
-- See Note [The superclass story] in GHC.Tc.Solver.Canonical
- -- True <=> (a) cc_class has superclasses
- -- (b) we have not (yet) added those
- -- superclasses as Givens
+ -- See Note [SimplifyInfer with UndecidableSuperClasses] in GHC.Tc.Solver
+ -- n > 0 <=> (a) cc_class has superclasses
+ -- (b) we have not (yet) explored those superclasses
}
| CIrredCan { -- These stand for yet-unusable predicates
@@ -273,8 +282,11 @@ data QCInst -- A much simplified version of ClsInst
-- Always Given
, qci_tvs :: [TcTyVar] -- The tvs
, qci_pred :: TcPredType -- The ty
- , qci_pend_sc :: Bool -- Same as cc_pend_sc flag in CDictCan
- -- Invariant: True => qci_pred is a ClassPred
+ , qci_pend_sc :: ExpansionFuel -- Invariants: qci_pend_sc > 0 => qci_pred is a ClassPred
+ -- and the superclasses are unexplored
+ -- Same as cc_pend_sc flag in CDictCan
+ -- See Note [SimplifyInfer with UndecidableSuperClasses]
+ -- in GHC.Tc.Solver
}
instance Outputable QCInst where
@@ -673,11 +685,11 @@ instance Outputable Ct where
CEqCan {} -> text "CEqCan"
CNonCanonical {} -> text "CNonCanonical"
CDictCan { cc_pend_sc = psc }
- | psc -> text "CDictCan(psc)"
- | otherwise -> text "CDictCan"
+ | psc > 0 -> text "CDictCan" <> parens (text "psc" <+> ppr psc)
+ | otherwise -> text "CDictCan"
CIrredCan { cc_reason = reason } -> text "CIrredCan" <> ppr reason
- CQuantCan (QCI { qci_pend_sc = pend_sc })
- | pend_sc -> text "CQuantCan(psc)"
+ CQuantCan (QCI { qci_pend_sc = psc })
+ | psc > 0 -> text "CQuantCan" <> parens (text "psc" <+> ppr psc)
| otherwise -> text "CQuantCan"
-----------------------------------
@@ -893,23 +905,24 @@ isUserTypeError pred = case getUserTypeErrorMsg pred of
_ -> False
isPendingScDict :: Ct -> Bool
-isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc
--- Says whether this is a CDictCan with cc_pend_sc is True;
+isPendingScDict (CDictCan { cc_pend_sc = psc }) = psc > 0
+-- Says whether this is a CDictCan with cc_pend_sc has positive fuel;
-- i.e. pending un-expanded superclasses
isPendingScDict _ = False
pendingScDict_maybe :: Ct -> Maybe Ct
--- Says whether this is a CDictCan with cc_pend_sc is True,
--- AND if so flips the flag
-pendingScDict_maybe ct@(CDictCan { cc_pend_sc = True })
- = Just (ct { cc_pend_sc = False })
+-- Says whether this is a CDictCan with cc_pend_sc has fuel left,
+-- AND if so exhausts the fuel so that they are not expanded again
+pendingScDict_maybe ct@(CDictCan { cc_pend_sc = n })
+ | n > 0 = Just (ct { cc_pend_sc = doNotExpand })
+ | otherwise = Nothing
pendingScDict_maybe _ = Nothing
pendingScInst_maybe :: QCInst -> Maybe QCInst
-- Same as isPendingScDict, but for QCInsts
-pendingScInst_maybe qci@(QCI { qci_pend_sc = True })
- = Just (qci { qci_pend_sc = False })
-pendingScInst_maybe _ = Nothing
+pendingScInst_maybe qci@(QCI { qci_pend_sc = n })
+ | n > 0 = Just (qci { qci_pend_sc = doNotExpand })
+ | otherwise = Nothing
superClassesMightHelp :: WantedConstraints -> Bool
-- ^ True if taking superclasses of givens, or of wanteds (to perhaps
@@ -928,11 +941,12 @@ superClassesMightHelp (WC { wc_simple = simples, wc_impl = implics })
is_ip _ = False
getPendingWantedScs :: Cts -> ([Ct], Cts)
+-- in the return values [Ct] has original fuel while Cts has fuel exhausted
getPendingWantedScs simples
= mapAccumBagL get [] simples
where
- get acc ct | Just ct' <- pendingScDict_maybe ct
- = (ct':acc, ct')
+ get acc ct | Just ct_exhausted <- pendingScDict_maybe ct
+ = (ct:acc, ct_exhausted)
| otherwise
= (acc, ct)
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -723,12 +723,14 @@ setIdCprSig id sig = modifyIdInfo (\info -> setCprSigInfo info sig) id
zapIdDmdSig :: Id -> Id
zapIdDmdSig id = modifyIdInfo (`setDmdSigInfo` nopSig) id
--- | This predicate says whether the 'Id' has a strict demand placed on it or
--- has a type such that it can always be evaluated strictly (i.e an
--- unlifted type, as of GHC 7.6). We need to
--- check separately whether the 'Id' has a so-called \"strict type\" because if
--- the demand for the given @id@ hasn't been computed yet but @id@ has a strict
--- type, we still want @isStrictId id@ to be @True at .
+-- | `isStrictId` says whether either
+-- (a) the 'Id' has a strict demand placed on it or
+-- (b) definitely has a \"strict type\", such that it can always be
+-- evaluated strictly (i.e an unlifted type)
+-- We need to check (b) as well as (a), because when the demand for the
+-- given `id` hasn't been computed yet but `id` has a strict
+-- type, we still want `isStrictId id` to be `True`.
+-- Returns False if the type is levity polymorphic; False is always safe.
isStrictId :: Id -> Bool
isStrictId id
| assertPpr (isId id) (text "isStrictId: not an id: " <+> ppr id) $
=====================================
compiler/GHC/Unit/Module/ModIface.hs
=====================================
@@ -3,6 +3,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE NamedFieldPuns #-}
module GHC.Unit.Module.ModIface
( ModIface
@@ -549,20 +550,58 @@ emptyIfaceHashCache _occ = Nothing
-- Take care, this instance only forces to the degree necessary to
-- avoid major space leaks.
-instance (NFData (IfaceBackendExts (phase :: ModIfacePhase)), NFData (IfaceDeclExts (phase :: ModIfacePhase))) => NFData (ModIface_ phase) where
- rnf (ModIface f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12
- f13 f14 f15 f16 f17 f18 f19 f20 f21 f22 f23 f24) =
- rnf f1 `seq` rnf f2 `seq` f3 `seq` f4 `seq` f5 `seq` f6 `seq` rnf f7 `seq` f8 `seq`
- f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` f13 `seq` rnf f14 `seq` rnf f15 `seq` rnf f16 `seq`
- rnf f17 `seq` f18 `seq` rnf f19 `seq` rnf f20 `seq` rnf f21 `seq` f22 `seq` f23 `seq` rnf f24
+instance ( NFData (IfaceBackendExts (phase :: ModIfacePhase))
+ , NFData (IfaceDeclExts (phase :: ModIfacePhase))
+ ) => NFData (ModIface_ phase) where
+ rnf (ModIface{ mi_module, mi_sig_of, mi_hsc_src, mi_deps, mi_usages
+ , mi_exports, mi_used_th, mi_fixities, mi_warns, mi_anns
+ , mi_decls, mi_extra_decls, mi_globals, mi_insts
+ , mi_fam_insts, mi_rules, mi_hpc, mi_trust, mi_trust_pkg
+ , mi_complete_matches, mi_docs, mi_final_exts
+ , mi_ext_fields, mi_src_hash})
+ = rnf mi_module
+ `seq` rnf mi_sig_of
+ `seq` mi_hsc_src
+ `seq` mi_deps
+ `seq` mi_usages
+ `seq` mi_exports
+ `seq` rnf mi_used_th
+ `seq` mi_fixities
+ `seq` mi_warns
+ `seq` rnf mi_anns
+ `seq` rnf mi_decls
+ `seq` rnf mi_extra_decls
+ `seq` mi_globals
+ `seq` rnf mi_insts
+ `seq` rnf mi_fam_insts
+ `seq` rnf mi_rules
+ `seq` rnf mi_hpc
+ `seq` mi_trust
+ `seq` rnf mi_trust_pkg
+ `seq` rnf mi_complete_matches
+ `seq` rnf mi_docs
+ `seq` mi_final_exts
+ `seq` mi_ext_fields
+ `seq` rnf mi_src_hash
`seq` ()
-
instance NFData (ModIfaceBackend) where
- rnf (ModIfaceBackend f1 f2 f3 f4 f5 f6 f7 f8 f9 f10 f11 f12 f13)
- = rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq`
- rnf f5 `seq` rnf f6 `seq` rnf f7 `seq` rnf f8 `seq`
- rnf f9 `seq` rnf f10 `seq` rnf f11 `seq` rnf f12 `seq` rnf f13
+ rnf (ModIfaceBackend{ mi_iface_hash, mi_mod_hash, mi_flag_hash, mi_opt_hash
+ , mi_hpc_hash, mi_plugin_hash, mi_orphan, mi_finsts, mi_exp_hash
+ , mi_orphan_hash, mi_warn_fn, mi_fix_fn, mi_hash_fn})
+ = rnf mi_iface_hash
+ `seq` rnf mi_mod_hash
+ `seq` rnf mi_flag_hash
+ `seq` rnf mi_opt_hash
+ `seq` rnf mi_hpc_hash
+ `seq` rnf mi_plugin_hash
+ `seq` rnf mi_orphan
+ `seq` rnf mi_finsts
+ `seq` rnf mi_exp_hash
+ `seq` rnf mi_orphan_hash
+ `seq` rnf mi_warn_fn
+ `seq` rnf mi_fix_fn
+ `seq` rnf mi_hash_fn
forceModIface :: ModIface -> IO ()
=====================================
docs/users_guide/expected-undocumented-flags.txt
=====================================
@@ -33,6 +33,9 @@
-fbang-patterns
-fbuilding-cabal-package
-fconstraint-solver-iterations
+-fgivens-expansion-fuel
+-fwanteds-expansion-fuel
+-fqcs-expansion-fuel
-fcontext-stack
-fcross-module-specialize
-fdiagnostics-color=always
=====================================
libraries/base/tests/all.T
=====================================
@@ -79,7 +79,9 @@ test('length001',
# excessive amounts of stack space. So we specifically set a low
# stack limit and mark it as failing under a few conditions.
[extra_run_opts('+RTS -K8m -RTS'),
- expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc'])],
+ expect_fail_for(['normal', 'threaded1', 'llvm', 'nonmoving', 'nonmoving_thr', 'nonmoving_thr_ghc']),
+ # JS doesn't support stack limit so the test sometimes passes just fine. We decrease the timeout duration to force the failure.
+ when(js_arch(), run_timeout_multiplier(0.2))],
compile_and_run, [''])
test('ratio001', normal, compile_and_run, [''])
=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -31,6 +31,7 @@ module Language.Haskell.TH.Syntax
-- $infix
) where
+import qualified Data.Fixed as Fixed
import Data.Data hiding (Fixity(..))
import Data.IORef
import System.IO.Unsafe ( unsafePerformIO )
@@ -1056,6 +1057,15 @@ instance Lift Natural where
liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (IntegerL (fromIntegral x)))
+instance Lift (Fixed.Fixed a) where
+ liftTyped x = unsafeCodeCoerce (lift x)
+ lift (Fixed.MkFixed x) = do
+ ex <- lift x
+ return (ConE mkFixedName `AppE` ex)
+ where
+ mkFixedName =
+ mkNameG DataName "base" "Data.Fixed" "MkFixed"
+
instance Integral a => Lift (Ratio a) where
liftTyped x = unsafeCodeCoerce (lift x)
lift x = return (LitE (RationalL (toRational x)))
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -7,6 +7,7 @@
* Add `TypeDataD` constructor to the `Dec` type for `type data`
declarations (GHC proposal #106).
+ * Add `instance Lift (Fixed a)`
## 2.19.0.0
=====================================
testsuite/driver/testlib.py
=====================================
@@ -129,14 +129,17 @@ def no_deps( name, opts):
def skip( name, opts ):
opts.skip = True
+def js_arch() -> bool:
+ return arch("javascript");
+
# disable test on JS arch
def js_skip( name, opts ):
- if arch("javascript"):
+ if js_arch():
skip(name,opts)
# expect broken for the JS backend
def js_broken( bug: IssueNumber ):
- if arch("javascript"):
+ if js_arch():
return expect_broken(bug);
else:
return normal;
=====================================
testsuite/tests/simplCore/should_compile/T22761.hs
=====================================
@@ -0,0 +1,40 @@
+module T22761 where
+
+import T22761a
+
+newtype Mod m = Mod m deriving Num
+
+gcdExt :: Integer -> (Integer, Integer)
+gcdExt x = go 0 x
+ where
+ go !_ 0 = (1, 1)
+ go r _ = go r r
+
+pow :: (Num m) => Mod m -> Mod m
+pow x = x*x*x
+{-# NOINLINE [1] pow #-}
+{-# RULES
+"powMod/3/Int" forall x. pow x = x*x*x
+#-}
+
+
+-- GHC puts `boo1` after `wom1` (since they don't appear connected)
+-- Then { wom1 = foo True } rewrites to { wom1 = boo False }
+-- so we need to do glomming. And that triggers the bug
+-- in the RULE for `pow`!
+--
+-- wom2/boo2 are there to still elicit the bug if
+-- GHC reverses its default ordering
+
+{-# RULES
+"wombat1" foo True = boo1 False
+#-}
+
+wom1 = foo True
+boo1 x = x
+
+{-# RULES
+"wombat2" foo True = boo2 False
+#-}
+boo2 x = x
+wom2 = foo True
=====================================
testsuite/tests/simplCore/should_compile/T22761a.hs
=====================================
@@ -0,0 +1,4 @@
+module T22761a where
+
+{-# NOINLINE [0] foo #-}
+foo x = x
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -471,5 +471,6 @@ test('T22611', [when(wordsize(32), skip), grep_errmsg(r'\$salterF') ], compile,
test('T22715_2', normal, multimod_compile, ['T22715_2', '-v0 -O -fspecialise-aggressively'])
test('T22802', normal, compile, ['-O'])
test('T15205', normal, compile, ['-O -ddump-simpl -dno-typeable-binds -dsuppress-uniques'])
+test('T22761', normal, multimod_compile, ['T22761', '-O2 -v0'])
test('RewriteHigherOrderPatterns', normal, compile, ['-O -ddump-rule-rewrites -dsuppress-all -dsuppress-uniques'])
=====================================
testsuite/tests/typecheck/should_compile/T21909.hs
=====================================
@@ -0,0 +1,24 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module T21909 where
+
+import Data.Kind
+
+class (Monad m, MyMonad (Inner m)) => MyMonad m where
+ type Inner m :: Type -> Type
+ foo :: m Int
+
+works :: MyMonad m => m String
+works = show <$> ((+ 1) <$> foo)
+
+fails :: MyMonad m => m String
+fails = show <$> fooPlusOne
+ where
+ fooPlusOne = (+ 1) <$> foo
+
+alsoFails :: MyMonad m => m String
+alsoFails =
+ let fooPlusOne = (+ 1) <$> foo
+ in show <$> fooPlusOne
=====================================
testsuite/tests/typecheck/should_compile/T21909b.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE UndecidableSuperClasses, FunctionalDependencies, MultiParamTypeClasses, GADTs #-}
+
+module T21909b where
+
+class C [a] => C a where
+ foo :: a -> Int
+
+bar :: C a => a -> Int
+bar x = foolocal x
+ where
+ foolocal a = foo a
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -857,3 +857,5 @@ test('T22647', normal, compile, [''])
test('T19577', normal, compile, [''])
test('T22383', normal, compile, [''])
test('T21501', normal, compile, [''])
+test('T21909', normal, compile, [''])
+test('T21909b', normal, compile, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1e7ebe91fcc68e5d9857535d8b352a1b95725ae...b8c266eb17100cd908c65f3a39213ec1c5e06f24
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a1e7ebe91fcc68e5d9857535d8b352a1b95725ae...b8c266eb17100cd908c65f3a39213ec1c5e06f24
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/20230210/4479605c/attachment-0001.html>
More information about the ghc-commits
mailing list