[Git][ghc/ghc][wip/T24359] WIP: original approach but with TcSSpecPrag
sheaf (@sheaf)
gitlab at gitlab.haskell.org
Tue Jan 28 13:11:52 UTC 2025
sheaf pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
2ffae48c by sheaf at 2025-01-28T14:11:07+01:00
WIP: original approach but with TcSSpecPrag
- - - - -
14 changed files:
- compiler/GHC/Core/Predicate.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Solver/Default.hs
- compiler/GHC/Tc/Solver/Dict.hs
- compiler/GHC/Tc/Solver/Equality.hs
- compiler/GHC/Tc/Solver/Monad.hs
- compiler/GHC/Tc/Solver/Solve.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Tc/Zonk/Type.hs
- + testsuite/tests/simplCore/should_compile/DsSpecPragmas.hs
- testsuite/tests/simplCore/should_compile/all.T
- testsuite/tests/typecheck/should_compile/all.T
Changes:
=====================================
compiler/GHC/Core/Predicate.hs
=====================================
@@ -554,8 +554,8 @@ types/kinds are fully settled and zonked.
-- | Do a topological sort on a list of tyvars,
-- so that binders occur before occurrences
--- E.g. given [ a::k, k::*, b::k ]
--- it'll return a well-scoped list [ k::*, a::k, b::k ]
+-- E.g. given @[ a::k, k::Type, b::k ]@
+-- it'll return a well-scoped list @[ k::Type, a::k, b::k ]@.
--
-- This is a deterministic sorting operation
-- (that is, doesn't depend on Uniques).
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -824,7 +824,8 @@ instance NoAnn AnnSig where
-- | Type checker Specialisation Pragmas
--
--- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker to the desugarer
+-- 'TcSpecPrags' conveys @SPECIALISE@ pragmas from the type checker
+-- to the desugarer
data TcSpecPrags
= IsDefaultMethod -- ^ Super-specialised: a default method should
-- be macro-expanded at every call site
@@ -834,21 +835,36 @@ data TcSpecPrags
type LTcSpecPrag = Located TcSpecPrag
-- | Type checker Specialisation Pragma
--- This data type is used briefly, to communicate between the typechecker and renamer
+--
+-- This data type is used to communicate between the typechecker and
+-- the desugarer.
data TcSpecPrag
- = SpecPrag Id HsWrapper InlinePragma
- -- ^ The Id to be specialised, a wrapper that specialises the
- -- polymorphic function, and inlining spec for the specialised function
-
- | SpecPragE { spe_fn_nm :: Name -- The Name of the Id being specialised
- , spe_fn_id :: Id -- The Id being specialised
- -- The spe_fn_name may differ from (idName spe_fn_id) in the
- -- case of instance methods, where the Name is the class-op
- -- selector but the spe_fn_id is that for the local method
-
- , spe_bndrs :: [Var] -- TyVars, EvVars, and Ids
- , spe_call :: LHsExpr GhcTc -- The LHS of the RULE: a call of f
- , spe_inl :: InlinePragma }
+ -- | Old-form specialise pragma
+ = SpecPrag
+ Id
+ -- ^ 'Id' to be specialised
+ HsWrapper
+ -- ^ wrapper that specialises the polymorphic function
+ InlinePragma
+ -- ^ inlining spec for the specialised function
+ -- | New-form specialise pragma
+ | SpecPragE
+ { spe_fn_nm :: Name
+ -- ^ 'Name' of the 'Id' being specialised
+ , spe_fn_id :: Id
+ -- ^ 'Id' being specialised
+ --
+ -- Note that 'spe_fn_nm' may differ from @'idName' 'spe_fn_id'@
+ -- in the case of instance methods, where the 'Name' is the
+ -- class-op selector but the 'spe_fn_id' is that for the local method
+ , spe_inl :: InlinePragma
+ -- ^ (optional) INLINE annotation and activation phase annotation
+
+ , spe_bndrs :: [Var]
+ -- ^ TyVars, EvVars, and Ids
+ , spe_call :: LHsExpr GhcTc
+ -- ^ The type-checked specialise expression
+ }
noSpecPrags :: TcSpecPrags
noSpecPrags = SpecPrags []
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -823,7 +823,7 @@ Notice that
let { d = d2; d1 = $dfOrdInt } in f @Int @b (d2:Eq b)
Do no inlining in this "simple optimiser" phase: use `simpleOptExprNoInline`.
E.g. we don't want to turn
- let { d1=d; d2=d } in f d d --> f d d
+ let { d1=d; d2=d } in f d1 d2 --> f d d
because the latter is harder to match.
(SP2) the function `prepareSpecLHS` takes the simplified LHS `core_call` and
@@ -921,14 +921,19 @@ dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)
rule_bndrs poly_id rule_lhs_args
spec_bndrs core_app spec_inl } }
-dsSpec poly_rhs (SpecPragE { spe_fn_nm = poly_nm
- , spe_fn_id = poly_id
- , spe_bndrs = bndrs
- , spe_call = the_call
- , spe_inl = inl })
+dsSpec poly_rhs (
+ SpecPragE
+ { spe_fn_nm = poly_nm
+ , spe_fn_id = poly_id
+ , spe_inl = inl
+ , spe_bndrs = bndrs
+ , spe_call = the_call
+ })
-- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
- = do { ds_call <- zapUnspecables $ -- zapUnspecables: see
- dsLExpr the_call -- Note [Desugaring RULE left hand sides]
+ = do { ds_call <- unsetGOptM Opt_EnableRewriteRules $ -- Note [Desugaring RULE left hand sides]
+ unsetWOptM Opt_WarnIdentities $
+ zapUnspecables $
+ dsLExpr the_call
-- Simplify the (desugared) call; see wrinkle (SP1)
-- in Note [Desugaring SPECIALISE pragmas]
@@ -1054,7 +1059,7 @@ finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
; tracePm "dsSpec" (vcat
[ text "fun:" <+> ppr poly_id
- , text "spec_bndrs:" <+> ppr spec_bndrs
+ , text "spec_bndrs:" <+> ppr spec_bndrs
, text "args:" <+> ppr rule_args ])
; return (unitOL (spec_id, spec_rhs), rule) }
-- NB: do *not* use makeCorePair on (spec_id,spec_rhs), because
@@ -1077,7 +1082,7 @@ finishSpecPrag poly_nm poly_rhs rule_bndrs poly_id rule_args
| all is_nop_arg rule_args, not (isInlinePragma spec_inl)
-- The specialisation does nothing.
- -- But don't compliain if it is SPECIALISE INLINE (#4444)
+ -- But don't complain if it is SPECIALISE INLINE (#4444)
= Just UselessSpecialiseNoSpecialisation
| otherwise
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -39,7 +39,7 @@ import GHC.Tc.Gen.HsType
import GHC.Tc.Solver( reportUnsolvedEqualities, pushLevelAndSolveEqualitiesX
, emitResidualConstraints )
import GHC.Tc.Solver.Solve( solveWanteds )
-import GHC.Tc.Solver.Monad( runTcS, runTcSWithEvBinds )
+import GHC.Tc.Solver.Monad( runTcS, runTcSSpecPragWithEvBinds )
import GHC.Tc.Validity ( checkValidType )
import GHC.Tc.Utils.Monad
@@ -50,7 +50,7 @@ import GHC.Tc.Utils.Instantiate( topInstantiate, tcInstTypeBndrs )
import GHC.Tc.Utils.Env
import GHC.Tc.Types.Origin
-import GHC.Tc.Types.Evidence( HsWrapper(..), (<.>), TcEvBinds(..) )
+import GHC.Tc.Types.Evidence
import GHC.Tc.Types.Constraint
import GHC.Tc.Zonk.TcType
@@ -703,17 +703,24 @@ Note [Handling new-form SPECIALISE pragmas]
New-form SPECIALISE pragmas are described by GHC Proposal #493.
The pragma takes the form of a function application, possibly with intervening
-parens and type signatures, with a variable at the head. It may have rule
-for-alls at the top. e.g.
+parens and type signatures, with a variable at the head:
{-# SPECIALISE f1 @Int 3 #-}
- {-# SPECIALISE forall x xs. f2 (x:xs) #-}
- {-# SPECIALISE f3 :: Int -> Int #-}
- {-# SPECIALISE (f4 :: Int -> Int) 5 #-}
+ {-# SPECIALISE f2 :: Int -> Int #-}
+ {-# SPECIALISE (f3 :: Int -> Int) 5 #-}
+
+It may also have rule for-alls at the top, e.g.
+
+ {-# SPECIALISE forall x xs. f4 (x:xs) #-}
{-# SPECIALISE forall a. forall x xs. f5 @a @a (x:xs) #-}
See `GHC.Rename.Bind.checkSpecESigShape` for the shape-check.
+We are going to use the following (perhaps somewhat contrived) example to
+demonstrate the subtle aspects of the implementation:
+
+ f :: forall a b c d. (Eq a, Eq b, Eq c, Eq d) => a -> b -> c -> d -> Bool -> blah
+ {-# SPECIALISE forall t. forall x y z. f (x::[Proxy t]) y y [z] True #-}
Example:
f :: forall a b. (Eq a, Eq b, Eq c) => a -> b -> c -> Bool -> blah
@@ -755,26 +762,46 @@ Note that
spec_const_binds = let d1 = $fEqInt
d3 = d2
-How it works:
+This is done in three parts.
+
+ A. Typechecker: `GHC.Tc.Gen.Sig.tcSpecPrag`
+
+ (1) Typecheck the expression, capturing its constraints
+
+ (2) Simplify these constraints, in special TcSSpecPrag mode
+ SLD TODO add more details.
+
+ (3) Decide which constraints to quantify over, and quantify.
-* `GHC.Tc.Gen.Sig.tcSpecPrag` just typechecks the expression, putting the results
- into a `SpecPragE` record. Nothing very exciting happens here.
+ (4) Emit the residual (non-quantified) constraints, and wrap the
+ expression in a let binding for those constraints.
-* `GHC.Tc.Zonk.Type.zonkLTcSpecPrags` does a little extra work to collect any
- free type variables of the LHS. See Note [Free tyvars on rule LHS] in
- GHC.Tc.Zonk.Type. These weren't conveniently available earlier.
+ (5) Store all the information in a 'SpecPragE' record, to be consumed
+ by the desugarer.
-* `GHC.HsToCore.Binds.dsSpec` does the clever stuff:
+ B. Zonker: `GHC.Tc.Zonk.Type.zonkLTcSpecPrags`
- * Simplifies the expression. This is important because a type signature in the
- expression will have led to type/dictionary abstractions/applications. Now
- it should look like
- let <dict-binds> in f e1 e1 e3
+ The zonker does a little extra work to collect any free type variables
+ of the LHS. See Note [Free tyvars on rule LHS] in GHC.Tc.Zonk.Type.
+ These weren't conveniently available earlier.
- * `prepareSpecLHS` identifies the `spec_const_binds` (see above), discards
- the other dictionary bindings, and decomposes the call.
+ C. Desugarer: `GHC.HsToCore.Binds.dsSpec`.
- * Then it can build the RULE and specialised function.
+ This is where most of the clever stuff happens. See
+ Note [Desugaring SPECIALISE pragmas] in GHC.HsToCore.Binds for details,
+ but in brief:
+
+ (1) Simplify the expression. This is important because a type signature in
+ the expression will have led to type/dictionary abstractions/applications.
+ Now it should look like
+ let <dict-binds> in f d1 d2 d3
+
+ (2) `prepareSpecLHS` identifies the `spec_const_binds`, discards the other
+ dictionary bindings, and decomposes the call.
+
+ (3) Then we build the specialised function $sf, and concoct a RULE
+ of the form:
+ forall @a @b d1 d2 d3. f d1 d2 d3 = $sf d1 d2 d3
Note [Handling old-form SPECIALISE pragmas]
@@ -944,38 +971,41 @@ tcSpecPrag poly_id prag@(SpecSig _ fun_name hs_tys inl)
; return (SpecPrag poly_id wrap inl) }
tcSpecPrag poly_id (SpecSigE nm rule_bndrs spec_e inl)
- = do { -- Typecheck the expression, spec_e, capturing its constraints
+ -- For running commentary, see Note [Handling new-form SPECIALISE pragmas]
+ = do { -- (1) Typecheck the expression, spec_e, capturing its constraints
let skol_info_anon = SpecESkol nm
- ; traceTc "tcSpecPrag: specSigE1" (ppr nm $$ ppr spec_e)
+ ; traceTc "tcSpecPrag SpecSigE 1" (ppr nm $$ ppr spec_e)
; skol_info <- mkSkolemInfo skol_info_anon
- ; (rhs_tclvl, wanted, (rule_bndrs', (spec_e', _rho)))
+ ; (rhs_tclvl, wanted, (rule_bndrs', (tc_spec_e, _rho)))
<- tcRuleBndrs skol_info rule_bndrs $
tcInferRho spec_e
- -- Simplify the constraints
+ -- (2) Simplify the constraints, in special TcSSpecPrag mode
; ev_binds_var <- newTcEvBinds
; wanted <- setTcLevel rhs_tclvl $
- runTcSWithEvBinds ev_binds_var $
+ runTcSSpecPragWithEvBinds ev_binds_var $
solveWanteds wanted
- -- Quantify over the the constraints
+ -- (3) Quantify over the constraints
; qevs <- mapM newEvVar $
ctsPreds $
approximateWC False wanted
+ -- (4) Emit the residual (non-quantified) constraints,
+ -- and wrap the expression in the evidence let bindings
; let tv_bndrs = filter isTyVar rule_bndrs'
; emitResidualConstraints rhs_tclvl skol_info_anon ev_binds_var
emptyVarSet tv_bndrs qevs
wanted
+ ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) tc_spec_e
; traceTc "tcSpecPrag:SpecSigE" $
vcat [ text "nm:" <+> ppr nm
, text "rule_bndrs':" <+> ppr rule_bndrs'
, text "qevs:" <+> ppr qevs
- , text "spec_e:" <+> ppr spec_e'
+ , text "spec_e:" <+> ppr tc_spec_e
, text "inl:" <+> ppr inl ]
- ; let lhs_call = mkLHsWrap (WpLet (TcEvBinds ev_binds_var)) spec_e'
; return [SpecPragE { spe_fn_nm = nm
, spe_fn_id = poly_id
, spe_bndrs = qevs ++ rule_bndrs' -- Dependency order
@@ -1414,9 +1444,9 @@ in `getRuleQuantCts`. Why not?
* Equality constraints are unboxed, and that leads to complications
For example equality constraints from the LHS will emit coercion hole
Wanteds. These don't have a name, so we can't quantify over them directly.
- Instead, in `mk_one` in `getRuleQuantCts` in we'd have to invent a new EvVar
- for the coercion, fill the hole with the invented EvVar, and then quantify
- over the EvVar. Here is old code from `mk_one`
+ Instead, in `getRuleQuantCts`, we'd have to invent a new EvVar for the
+ coercion, fill the hole with the invented EvVar, and then quantify over the
+ EvVar. Here is old code from `mk_one`
do { ev_id <- newEvVar pred
; fillCoercionHole hole (mkCoVarCo ev_id)
; return ev_id }
@@ -1483,7 +1513,8 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted
; lhs_wanted <- liftZonkM $ zonkWC lhs_wanted
-- Note [The SimplifyRule Plan] step 3
- ; (quant_evs, residual_lhs_wanted) <-getRuleQuantCts lhs_wanted
+ ; (quant_cts, residual_lhs_wanted) <- getRuleQuantCts lhs_wanted
+ ; let quant_evs = map ctEvId (bagToList quant_cts)
; traceTc "simplifyRule" $
vcat [ text "LHS of rule" <+> doubleQuotes (ftext name)
@@ -1496,7 +1527,7 @@ simplifyRule name tc_lvl lhs_wanted rhs_wanted
; return (quant_evs, residual_lhs_wanted, dont_default) }
-getRuleQuantCts :: WantedConstraints -> TcM ([EvVar], WantedConstraints)
+getRuleQuantCts :: WantedConstraints -> TcM (Cts, WantedConstraints)
-- Extract all the constraints that we can quantify over,
-- also returning the depleted WantedConstraints
--
@@ -1504,20 +1535,17 @@ getRuleQuantCts :: WantedConstraints -> TcM ([EvVar], WantedConstraints)
-- and attempt to solve them from the quantified constraints. Instead
-- we /partition/ the WantedConstraints into ones to quantify and ones
-- we can't quantify. We could use approximateWC instead, and leave
--- `wanted` unchanged; but then we'd have clone fresh binders and
+-- `wanted` unchanged; but then we'd have to clone fresh binders and
-- generate silly identity bindings. Seems more direct to do this.
--- Probably not a big eal wither way.
+-- Probably not a big deal wither way.
--
-- NB: we must look inside implications, because with
-- -fdefer-type-errors we generate implications rather eagerly;
-- see GHC.Tc.Utils.Unify.implicationNeeded. Not doing so caused #14732.
getRuleQuantCts wc
- = do { quant_evs <- mapM mk_one (bagToList quant_cts)
- ; return (quant_evs, residual_wc) }
+ = return $ float_wc emptyVarSet wc
where
- (quant_cts, residual_wc) = float_wc emptyVarSet wc
-
float_wc :: TcTyCoVarSet -> WantedConstraints -> (Cts, WantedConstraints)
float_wc skol_tvs (WC { wc_simple = simples, wc_impl = implics, wc_errors = errs })
= ( simple_yes `andCts` implic_yes
@@ -1542,17 +1570,6 @@ getRuleQuantCts wc
EqPred {} -> False -- Note [RULE quantification over equalities]
_ -> tyCoVarsOfCt ct `disjointVarSet` skol_tvs
- mk_one :: Ct -> TcM EvVar
- mk_one ct
- | CtWanted { ctev_dest = dest } <- ctEvidence ct
- , EvVarDest ev_id <- dest
- -- HoleDest can't happen because we don't quantify
- -- over EqPred: See rule_quant_ct above
- = return ev_id
-
- | otherwise
- = pprPanic "getRuleQuantCts" (ppr ct)
-
{- Note [Quantifying over equalities in RULES]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Solver/Default.hs
=====================================
@@ -973,7 +973,7 @@ tryDefaultGroup wanteds (Proposal assignments)
errInvalidDefaultedTyVar :: WantedConstraints -> Proposal -> NonEmpty TcTyVar -> TcS ()
errInvalidDefaultedTyVar wanteds (Proposal assignments) problematic_tvs
- = failTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems
+ = failWithTcS $ TcRnInvalidDefaultedTyVar tidy_wanteds tidy_assignments tidy_problems
where
proposal_tvs = concatMap (\(tv, ty) -> tv : tyCoVarsOfTypeList ty) assignments
tidy_env = tidyFreeTyCoVars emptyTidyEnv $ proposal_tvs ++ NE.toList problematic_tvs
=====================================
compiler/GHC/Tc/Solver/Dict.hs
=====================================
@@ -3,6 +3,7 @@
-- | Solving Class constraints CDictCan
module GHC.Tc.Solver.Dict (
solveDict, solveDictNC,
+ shortCutSolver,
checkInstanceOK,
matchLocalInst, chooseInstance,
makeSuperClasses, mkStrictSuperClasses,
@@ -727,7 +728,9 @@ try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys
do { -- First to try to solve it /completely/ from top level instances
-- See Note [Shortcut solving]
dflags <- getDynFlags
- ; short_cut_worked <- shortCutSolver dflags ev_w ev_i
+ ; short_cut_worked <- if wantShortCut dflags ev_w ev_i
+ then shortCutSolver dflags ev_w
+ else return False
; if short_cut_worked
then stopWith ev_w "interactDict/solved from instance"
@@ -755,31 +758,42 @@ try_inert_dicts inerts dict_w@(DictCt { di_ev = ev_w, di_cls = cls, di_tys = tys
= do { traceTcS "tryInertDicts:no" (ppr dict_w $$ ppr cls <+> ppr tys)
; continueWith () }
--- See Note [Shortcut solving]
-shortCutSolver :: DynFlags
- -> CtEvidence -- Work item
- -> CtEvidence -- Inert we want to try to replace
- -> TcS Bool -- True <=> success
-shortCutSolver dflags ev_w ev_i
- | isWanted ev_w
- , isGiven ev_i
+-- | See Note [Shortcut solving]
+wantShortCut :: DynFlags
+ -> CtEvidence -- ^ Work item
+ -> CtEvidence -- ^ Inert we want to try to replace
+ -> Bool
+wantShortCut dflags ev_w ev_i =
+ and
+ [ isWanted ev_w
+ , isGiven ev_i
-- We are about to solve a [W] constraint from a [G] constraint. We take
-- a moment to see if we can get a better solution using an instance.
-- Note that we only do this for the sake of performance. Exactly the same
-- programs should typecheck regardless of whether we take this step or
-- not. See Note [Shortcut solving]
- , not (isIPLikePred (ctEvPred ev_w)) -- Not for implicit parameters (#18627)
-
- , not (xopt LangExt.IncoherentInstances dflags)
+ , not (xopt LangExt.IncoherentInstances dflags)
-- If IncoherentInstances is on then we cannot rely on coherence of proofs
-- in order to justify this optimization: The proof provided by the
-- [G] constraint's superclass may be different from the top-level proof.
-- See Note [Shortcut solving: incoherence]
- , gopt Opt_SolveConstantDicts dflags
+ , gopt Opt_SolveConstantDicts dflags
-- Enabled by the -fsolve-constant-dicts flag
+ ]
+-- | See Note [Shortcut solving]
+shortCutSolver :: DynFlags
+ -> CtEvidence -- Work item
+ -> TcS Bool -- True <=> success
+shortCutSolver dflags ev_w
+ | isIPLikePred (ctEvPred ev_w)
+ -- Not for implicit parameters (#18627)
+ -- TODO: we should probably also reject QCs,
+ -- e.g. ( forall a. Eq a => IP "ip" a )
+ = return False
+ | otherwise
= do { ev_binds_var <- getTcEvBindsVar
; ev_binds <- assertPpr (not (isCoEvBindsVar ev_binds_var )) (ppr ev_w) $
getTcEvBindsMap ev_binds_var
@@ -795,8 +809,6 @@ shortCutSolver dflags ev_w ev_i
; setSolvedDicts solved_dicts'
; return True } }
- | otherwise
- = return False
where
-- This `CtLoc` is used only to check the well-staged condition of any
-- candidate DFun. Our subgoals all have the same stage as our root
@@ -806,46 +818,51 @@ shortCutSolver dflags ev_w ev_i
try_solve_from_instance -- See Note [Shortcut try_solve_from_instance]
:: (EvBindMap, DictMap DictCt) -> CtEvidence
-> MaybeT TcS (EvBindMap, DictMap DictCt)
- try_solve_from_instance (ev_binds, solved_dicts) ev
- | let pred = ctEvPred ev
- , ClassPred cls tys <- classifyPredType pred
- = do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w
- ; lift $ warn_custom_warn_instance inst_res loc_w
- -- See Note [Implementation of deprecated instances]
- ; case inst_res of
- OneInst { cir_new_theta = preds
- , cir_mk_ev = mk_ev
- , cir_canonical = canonical
- , cir_what = what }
- | safeOverlap what
- , all isTyFamFree preds -- Note [Shortcut solving: type families]
- -> do { let dict_ct = DictCt { di_ev = ev, di_cls = cls
- , di_tys = tys, di_pend_sc = doNotExpand }
- solved_dicts' = addSolvedDict dict_ct solved_dicts
- -- solved_dicts': it is important that we add our goal
- -- to the cache before we solve! Otherwise we may end
- -- up in a loop while solving recursive dictionaries.
-
- ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
- ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred
- ; lift $ checkReductionDepth loc' pred
-
-
- ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds
- -- Emit work for subgoals but use our local cache
- -- so we can solve recursive dictionaries.
-
- ; let ev_tm = mk_ev (map getEvExpr evc_vs)
- ev_binds' = extendEvBinds ev_binds $
- mkWantedEvBind (ctEvEvId ev) canonical ev_tm
-
- ; foldlM try_solve_from_instance (ev_binds', solved_dicts') $
- freshGoals evc_vs }
-
- _ -> mzero }
+ try_solve_from_instance (ev_binds, solved_dicts) ev =
+ case classifyPredType pred of
+ ClassPred cls tys ->
+ do { inst_res <- lift $ matchGlobalInst dflags True cls tys loc_w
+ ; lift $ warn_custom_warn_instance inst_res loc_w
+ -- See Note [Implementation of deprecated instances]
+ ; case inst_res of
+ OneInst { cir_new_theta = preds
+ , cir_mk_ev = mk_ev
+ , cir_canonical = canonical
+ , cir_what = what }
+ | safeOverlap what
+ , all isTyFamFree preds -- Note [Shortcut solving: type families]
+ -> do { let dict_ct = DictCt { di_ev = ev, di_cls = cls
+ , di_tys = tys, di_pend_sc = doNotExpand }
+ solved_dicts' = addSolvedDict dict_ct solved_dicts
+ -- solved_dicts': it is important that we add our goal
+ -- to the cache before we solve! Otherwise we may end
+ -- up in a loop while solving recursive dictionaries.
- | otherwise
- = mzero
+ ; lift $ traceTcS "shortCutSolver: found instance" (ppr preds)
+ ; loc' <- lift $ checkInstanceOK (ctEvLoc ev) what pred
+ ; lift $ checkReductionDepth loc' pred
+
+
+ ; evc_vs <- mapM (new_wanted_cached ev loc' solved_dicts') preds
+ -- Emit work for subgoals but use our local cache
+ -- so we can solve recursive dictionaries.
+
+ ; let ev_tm = mk_ev (map getEvExpr evc_vs)
+ ev_binds' = extendEvBinds ev_binds $
+ mkWantedEvBind (ctEvEvId ev) canonical ev_tm
+
+ ; foldlM try_solve_from_instance (ev_binds', solved_dicts') $
+ freshGoals evc_vs }
+
+ _other_inst_res -> mzero }
+
+ ForAllPred _tvs _theta _body ->
+ -- TODO: implement short-cut solving for quantified constraints
+ mzero
+
+ _other_pred -> mzero
+ where
+ pred = ctEvPred ev
-- Use a local cache of solved dicts while emitting EvVars for new work
@@ -868,13 +885,16 @@ shortCutSolver dflags ev_w ev_i
tryInstances :: DictCt -> SolverStage ()
tryInstances dict_ct
- = Stage $ do { inerts <- getInertSet
- ; try_instances inerts dict_ct }
+ = Stage $ do { dflags <- getDynFlags
+ ; inerts <- getInertSet
+ ; mode <- getModeTcS
+ ; try_instances inerts dflags mode dict_ct }
-try_instances :: InertSet -> DictCt -> TcS (StopOrContinue ())
+try_instances :: InertSet -> DynFlags -> TcSMode -> DictCt -> TcS (StopOrContinue ())
-- Try to use type-class instance declarations to simplify the constraint
-try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls
- , di_tys = xis })
+try_instances inerts dflags mode
+ work_item@(DictCt { di_ev = ev, di_cls = cls
+ , di_tys = xis })
| isGiven ev -- Never use instances for Given constraints
= continueWith ()
-- See Note [No Given/Given fundeps]
@@ -883,17 +903,26 @@ try_instances inerts work_item@(DictCt { di_ev = ev, di_cls = cls
= do { setEvBindIfWanted ev EvCanonical (ctEvTerm solved_ev)
; stopWith ev "Dict/Top (cached)" }
+ | TcSSpecPrag <- mode
+ -- In TcSSpecPrag mode, we only want to "fully solve" constraints
+ -- from instances. Making partial progress using instances is
+ -- actively harmful; see Note [Handling new-form SPECIALISE pragmas].
+ = do { shortcut_worked <- shortCutSolver dflags ev
+ ; if shortcut_worked
+ then stopWith ev "TcSSpecPrag DictCt: short-cut fully solved Wanted from instances"
+ else continueWith ()
+ }
+
| otherwise -- Wanted, but not cached
- = do { dflags <- getDynFlags
- ; lkup_res <- matchClassInst dflags inerts cls xis dict_loc
- ; case lkup_res of
- OneInst { cir_what = what }
- -> do { insertSafeOverlapFailureTcS what work_item
- ; updSolvedDicts what work_item
- ; chooseInstance ev lkup_res }
- _ -> -- NoInstance or NotSure
- -- We didn't solve it; so try functional dependencies
- continueWith () }
+ = do { lkup_res <- matchClassInst dflags inerts cls xis dict_loc
+ ; case lkup_res of
+ OneInst { cir_what = what }
+ -> do { insertSafeOverlapFailureTcS what work_item
+ ; updSolvedDicts what work_item
+ ; chooseInstance ev lkup_res }
+ _ -> -- NoInstance or NotSure
+ -- We didn't solve it; so try functional dependencies
+ continueWith () }
where
dict_loc = ctEvLoc ev
@@ -940,10 +969,12 @@ checkInstanceOK loc what pred
| otherwise
= loc
-matchClassInst :: DynFlags -> InertSet
+matchClassInst :: DynFlags
+ -> InertSet
-> Class -> [Type]
-> CtLoc -> TcS ClsInstResult
matchClassInst dflags inerts clas tys loc
+
-- First check whether there is an in-scope Given that could
-- match this constraint. In that case, do not use any instance
-- whether top level, or local quantified constraints.
=====================================
compiler/GHC/Tc/Solver/Equality.hs
=====================================
@@ -2018,8 +2018,9 @@ finishCanWithIrred :: CtIrredReason -> CtEvidence
-> TcS (StopOrContinue (Either IrredCt a))
finishCanWithIrred reason ev
= do { -- Abort fast if we have any insoluble Wanted constraints,
- -- and the TcS abort-if-insoluble flag is on.
- when (isInsolubleReason reason) tryEarlyAbortTcS
+ -- and the TcSMode is TcsHoleFits
+ mode <- getModeTcS
+ ; when (mode == TcSHoleFits && isInsolubleReason reason) failTcS
; continueWith $ Left $ IrredCt { ir_ev = ev, ir_reason = reason } }
=====================================
compiler/GHC/Tc/Solver/Monad.hs
=====================================
@@ -14,9 +14,10 @@
module GHC.Tc.Solver.Monad (
-- The TcS monad
- TcS, runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
- failTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,
- runTcSEqualities,
+ TcS, TcSMode(..),
+ runTcS, runTcSEarlyAbort, runTcSWithEvBinds, runTcSInerts,
+ runTcSEqualities, runTcSSpecPragWithEvBinds,
+ failTcS, failWithTcS, warnTcS, addErrTcS, wrapTcS, ctLocWarnTcS,
nestTcS, nestImplicTcS, setEvBindsTcS,
emitImplicationTcS, emitTvImplicationTcS,
emitFunDepWanteds,
@@ -37,7 +38,7 @@ module GHC.Tc.Solver.Monad (
stopWithStage, nopStage,
-- Tracing etc
- panicTcS, traceTcS, tryEarlyAbortTcS,
+ panicTcS, traceTcS, getModeTcS,
traceFireTcS, bumpStepCountTcS, csTraceTcS,
wrapErrTcS, wrapWarnTcS,
resetUnificationFlag, setUnificationFlag,
@@ -824,6 +825,8 @@ added. This is initialised from the innermost implication constraint.
data TcSEnv
= TcSEnv {
+ tcs_mode :: TcSMode,
+
tcs_ev_binds :: EvBindsVar,
tcs_unified :: IORef Int,
@@ -841,15 +844,27 @@ data TcSEnv
tcs_inerts :: IORef InertSet, -- Current inert set
- -- Whether to throw an exception if we come across an insoluble constraint.
- -- Used to fail-fast when checking for hole-fits. See Note [Speeding up
- -- valid hole-fits].
- tcs_abort_on_insoluble :: Bool,
-
-- See Note [WorkList priorities] in GHC.Tc.Solver.InertSet
tcs_worklist :: IORef WorkList -- Current worklist
}
+data TcSMode
+ = TcSVanilla
+
+ | TcSHoleFits -- ^ Throw an exception if we come across an insoluble constraint,
+ -- to fail-fast when checking for hole-fits.
+ --
+ -- See Note [Speeding up valid hole-fits].
+
+ | TcSSpecPrag -- ^ Don't use instance declarations or unpack forall constraints;
+ -- used when simplifying a SPECIALISE pragma.
+ deriving( Eq )
+
+instance Outputable TcSMode where
+ ppr TcSVanilla = text "TcSVanilla"
+ ppr TcSHoleFits = text "TcSHoleFits"
+ ppr TcSSpecPrag = text "TcSSpecPrag"
+
---------------
newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a }
deriving (Functor)
@@ -910,17 +925,17 @@ wrapWarnTcS :: TcM a -> TcS a
wrapWarnTcS = wrapTcS
panicTcS :: SDoc -> TcS a
-failTcS :: TcRnMessage -> TcS a
+failTcS :: TcS a
+failWithTcS :: TcRnMessage -> TcS a
warnTcS, addErrTcS :: TcRnMessage -> TcS ()
-failTcS = wrapTcS . TcM.failWith
+failTcS = wrapTcS TcM.failM
+failWithTcS = wrapTcS . TcM.failWith
warnTcS msg = wrapTcS (TcM.addDiagnostic msg)
addErrTcS = wrapTcS . TcM.addErr
panicTcS doc = pprPanic "GHC.Tc.Solver.Monad" doc
-tryEarlyAbortTcS :: TcS ()
--- Abort (fail in the monad) if the abort_on_insoluble flag is on
-tryEarlyAbortTcS
- = mkTcS (\env -> when (tcs_abort_on_insoluble env) TcM.failM)
+getModeTcS :: TcS TcSMode
+getModeTcS = mkTcS (\env -> return (tcs_mode env))
-- | Emit a warning within the 'TcS' monad at the location given by the 'CtLoc'.
ctLocWarnTcS :: CtLoc -> TcRnMessage -> TcS ()
@@ -976,11 +991,17 @@ csTraceTcM mk_doc
msg }) }
{-# INLINE csTraceTcM #-} -- see Note [INLINE conditional tracing utilities]
-runTcS :: TcS a -- What to run
- -> TcM (a, EvBindMap)
+runTcSWithEvBinds :: EvBindsVar -> TcS a -> TcM a
+runTcSWithEvBinds = runTcSWorker True TcSVanilla
+
+-- | This version of 'runTcSWithEvBinds' uses the 'TcSSpecPrag' mode.
+runTcSSpecPragWithEvBinds :: EvBindsVar -> TcS a -> TcM a
+runTcSSpecPragWithEvBinds = runTcSWorker True TcSSpecPrag
+
+runTcS :: TcS a -> TcM (a, EvBindMap)
runTcS tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; res <- runTcSWithEvBinds ev_binds_var tcs
+ ; res <- runTcSWorker True TcSVanilla ev_binds_var tcs
; ev_binds <- TcM.getTcEvBindsMap ev_binds_var
; return (res, ev_binds) }
@@ -990,51 +1011,47 @@ runTcS tcs
runTcSEarlyAbort :: TcS a -> TcM a
runTcSEarlyAbort tcs
= do { ev_binds_var <- TcM.newTcEvBinds
- ; runTcSWithEvBinds' True True ev_binds_var tcs }
+ ; runTcSWorker True TcSHoleFits ev_binds_var tcs }
-- | This can deal only with equality constraints.
runTcSEqualities :: TcS a -> TcM a
runTcSEqualities thing_inside
- = do { ev_binds_var <- TcM.newNoTcEvBinds
- ; runTcSWithEvBinds ev_binds_var thing_inside }
+ = do { ev_binds_var <- TcM.newNoTcEvBinds -- No bindings
+ ; runTcSWorker True TcSVanilla ev_binds_var thing_inside }
-- | A variant of 'runTcS' that takes and returns an 'InertSet' for
-- later resumption of the 'TcS' session.
runTcSInerts :: InertSet -> TcS a -> TcM (a, InertSet)
-runTcSInerts inerts tcs = do
- ev_binds_var <- TcM.newTcEvBinds
- runTcSWithEvBinds' False False ev_binds_var $ do
- setInertSet inerts
- a <- tcs
- new_inerts <- getInertSet
- return (a, new_inerts)
-
-runTcSWithEvBinds :: EvBindsVar
- -> TcS a
- -> TcM a
-runTcSWithEvBinds = runTcSWithEvBinds' True False
-
-runTcSWithEvBinds' :: Bool -- ^ Restore type variable cycles afterwards?
- -- Don't if you want to reuse the InertSet.
- -- See also Note [Type equality cycles]
- -- in GHC.Tc.Solver.Equality
- -> Bool
- -> EvBindsVar
- -> TcS a
- -> TcM a
-runTcSWithEvBinds' restore_cycles abort_on_insoluble ev_binds_var tcs
+runTcSInerts inerts tcs
+ = do { ev_binds_var <- TcM.newTcEvBinds
+ ; runTcSWorker False TcSVanilla ev_binds_var $
+ do { setInertSet inerts
+ ; a <- tcs
+ ; new_inerts <- getInertSet
+ ; return (a, new_inerts) } }
+
+-- runTcSWorker is not exported
+runTcSWorker :: Bool -- ^ Restore type variable cycles afterwards?
+ -- Don't if you want to reuse the InertSet.
+ -- See also Note [Type equality cycles]
+ -- in GHC.Tc.Solver.Equality
+ -> TcSMode
+ -> EvBindsVar
+ -> TcS a
+ -> TcM a
+runTcSWorker restore_cycles mode ev_binds_var tcs
= do { unified_var <- TcM.newTcRef 0
; step_count <- TcM.newTcRef 0
; inert_var <- TcM.newTcRef emptyInert
; wl_var <- TcM.newTcRef emptyWorkList
; unif_lvl_var <- TcM.newTcRef Nothing
- ; let env = TcSEnv { tcs_ev_binds = ev_binds_var
- , tcs_unified = unified_var
- , tcs_unif_lvl = unif_lvl_var
- , tcs_count = step_count
- , tcs_inerts = inert_var
- , tcs_abort_on_insoluble = abort_on_insoluble
- , tcs_worklist = wl_var }
+ ; let env = TcSEnv { tcs_mode = mode
+ , tcs_ev_binds = ev_binds_var
+ , tcs_unified = unified_var
+ , tcs_unif_lvl = unif_lvl_var
+ , tcs_count = step_count
+ , tcs_inerts = inert_var
+ , tcs_worklist = wl_var }
-- Run the computation
; res <- unTcS tcs env
@@ -1091,12 +1108,7 @@ nestImplicTcS :: EvBindsVar
-> TcLevel -> TcS a
-> TcS a
nestImplicTcS ref inner_tclvl (TcS thing_inside)
- = TcS $ \ TcSEnv { tcs_unified = unified_var
- , tcs_inerts = old_inert_var
- , tcs_count = count
- , tcs_unif_lvl = unif_lvl
- , tcs_abort_on_insoluble = abort_on_insoluble
- } ->
+ = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) ->
do { inerts <- TcM.readTcRef old_inert_var
; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack
(inert_cycle_breakers inerts)
@@ -1105,13 +1117,9 @@ nestImplicTcS ref inner_tclvl (TcS thing_inside)
-- All other InertSet fields are inherited
; new_inert_var <- TcM.newTcRef nest_inert
; new_wl_var <- TcM.newTcRef emptyWorkList
- ; let nest_env = TcSEnv { tcs_count = count -- Inherited
- , tcs_unif_lvl = unif_lvl -- Inherited
- , tcs_ev_binds = ref
- , tcs_unified = unified_var
- , tcs_inerts = new_inert_var
- , tcs_abort_on_insoluble = abort_on_insoluble
- , tcs_worklist = new_wl_var }
+ ; let nest_env = env { tcs_ev_binds = ref
+ , tcs_inerts = new_inert_var
+ , tcs_worklist = new_wl_var }
; res <- TcM.setTcLevel inner_tclvl $
thing_inside nest_env
=====================================
compiler/GHC/Tc/Solver/Solve.hs
=====================================
@@ -923,7 +923,7 @@ solveSimpleWanteds simples
-- See Note [The solveSimpleWanteds loop]
go n limit wc
| n `intGtLimit` limit
- = failTcS $ TcRnSimplifierTooManyIterations simples limit wc
+ = failWithTcS $ TcRnSimplifierTooManyIterations simples limit wc
| isEmptyBag (wc_simple wc)
= return (n,wc)
@@ -1053,7 +1053,7 @@ solveCt (CNonCanonical ev) = solveNC ev
solveCt (CIrredCan (IrredCt { ir_ev = ev })) = solveNC ev
solveCt (CEqCan (EqCt { eq_ev = ev, eq_eq_rel = eq_rel
- , eq_lhs = lhs, eq_rhs = rhs }))
+ , eq_lhs = lhs, eq_rhs = rhs }))
= solveEquality ev eq_rel (canEqLHSType lhs) rhs
solveCt (CQuantCan (QCI { qci_ev = ev, qci_pend_sc = pend_sc }))
@@ -1211,8 +1211,25 @@ solveForAllNC ev tvs theta pred
solveForAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType -> ExpansionFuel
-> TcS (StopOrContinue Void)
-- Precondition: already rewritten by inert set
-solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
- tvs theta pred _fuel
+solveForAll ev tvs theta pred fuel
+ = do { mode <- getModeTcS
+ ; solve_forAll ev tvs theta pred fuel mode
+ }
+
+solve_forAll :: CtEvidence -> [TcTyVar] -> TcThetaType -> PredType
+ -> ExpansionFuel -> TcSMode
+ -> TcS (StopOrContinue Void)
+solve_forAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_loc = loc })
+ tvs theta pred fuel mode
+ | TcSSpecPrag <- mode
+ = do { dflags <- getDynFlags
+ ; shortcut_worked <- shortCutSolver dflags ev
+ ; if shortcut_worked
+ then stopWith ev "TcSSpecPrag QC: short-cut fully solved Wanted from instances"
+ else do { addInertForAll qci
+ ; stopWith ev "TcSSpecPrag QC: Wanted kept as inert" }
+ }
+ | otherwise
= -- See Note [Solving a Wanted forall-constraint]
TcS.setSrcSpan (getCtLocEnvLoc $ ctLocEnv loc) $
-- This setSrcSpan is important: the emitImplicationTcS uses that
@@ -1257,9 +1274,11 @@ solveForAll ev@(CtWanted { ctev_dest = dest, ctev_rewriters = rewriters, ctev_lo
get_size pred = case classifyPredType pred of
ClassPred cls tys -> pSizeClassPred cls tys
_ -> pSizeType pred
+ qci = QCI { qci_ev = ev, qci_tvs = tvs
+ , qci_pred = pred, qci_pend_sc = fuel }
-- See Note [Solving a Given forall-constraint]
-solveForAll ev@(CtGiven {}) tvs _theta pred fuel
+solve_forAll ev@(CtGiven {}) tvs _theta pred fuel _mode
= do { addInertForAll qci
; stopWith ev "Given forall-constraint" }
where
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -373,10 +373,15 @@ data EvBindsVar
}
instance Data.Data TcEvBinds where
- -- Placeholder; we can't travers into TcEvBinds
+ -- Placeholder; we can't traverse into TcEvBinds
toConstr _ = abstractConstr "TcEvBinds"
gunfold _ _ = error "gunfold"
dataTypeOf _ = Data.mkNoRepType "TcEvBinds"
+instance Data.Data EvBind where
+ -- Placeholder; we can't traverse into EvBind
+ toConstr _ = abstractConstr "TcEvBind"
+ gunfold _ _ = error "gunfold"
+ dataTypeOf _ = Data.mkNoRepType "EvBind"
{- Note [Coercion evidence only]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -862,12 +862,14 @@ zonkLTcSpecPrags ps
; skol_tvs_ref <- lift $ newTcRef []
; setZonkType (SkolemiseFlexi skol_tvs_ref) $
-- SkolemiseFlexi: see Note [Free tyvars on rule LHS]
- runZonkBndrT (zonkCoreBndrsX bndrs) $ \bndrs' ->
+ runZonkBndrT (zonkCoreBndrsX bndrs) $ \ bndrs' ->
do { spec_e' <- zonkLExpr spec_e
; skol_tvs <- lift $ readTcRef skol_tvs_ref
- ; return (L loc (prag { spe_fn_id = poly_id'
- , spe_bndrs = skol_tvs ++ bndrs'
- , spe_call = spec_e' })) } }
+ ; return (L loc (prag { spe_fn_id = poly_id'
+ , spe_bndrs = skol_tvs ++ bndrs'
+ , spe_call = spec_e'
+ }))
+ }}
{-
************************************************************************
=====================================
testsuite/tests/simplCore/should_compile/DsSpecPragmas.hs
=====================================
@@ -0,0 +1,51 @@
+{-# LANGUAGE QuantifiedConstraints #-}
+
+module DsSpecPragmas where
+
+-- Some specialise pragmas that are difficult to generate the correct RULE for.
+
+--------------------------------------------------------------------------------
+
+f1 :: ( Num a, Eq b ) => a -> b -> Int
+f1 _ _ = 111
+
+-- Make sure we don't generate a rule with an LHS of the form
+--
+-- forall @e (d :: Eq e). f @[e] ($fEqList d) = ...
+--
+-- but rather
+--
+-- forall @e (d :: Eq [e]). f @[e] d = ...
+{-# SPECIALISE f1 :: Eq [e] => Word -> [e] -> Int #-}
+
+--------------------------------------------------------------------------------
+
+f2 :: ( Eq a, Eq b ) => a -> b -> Int
+f2 a b = if ( a == a ) == ( b == b ) then 1 else 2
+
+-- Make sure the rule LHS is of the form
+--
+-- f2 @c @c d1 d2 and not f2 @c @c d d
+{-# SPECIALISE f2 :: Eq c => c -> c -> Int #-}
+
+--------------------------------------------------------------------------------
+
+f3 :: ( Eq a, forall x. Eq x => Eq ( f x ) ) => f a -> Bool
+f3 z = z == z
+
+-- Discharge the quantified constraint but keep the 'Eq' constraint
+{-# SPECIALISE f3 :: Eq c => [ c ] -> Bool #-}
+
+-- Discharge the 'Eq' constraint but keep the quantified constraint
+{-# SPECIALISE f3 :: ( forall y. Eq y => Eq ( g y ) ) => g Int -> Bool #-}
+
+--------------------------------------------------------------------------------
+
+f4 :: Monad m => a -> m a
+f4 = return
+
+-- Check we can deal with locally quantified variables in constraints,
+-- in this case 'Monad (ST s)'.
+{-# SPECIALISE f4 :: b -> ST s b #-}
+
+--------------------------------------------------------------------------------
=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -502,6 +502,7 @@ test('T23491d', [extra_files(['T23491.hs']), grep_errmsg(r'Static argument')], m
test('T23074', normal, compile, ['-O -ddump-rules'])
test('T23272', [only_ways(['ghci']), extra_hc_opts('-fno-unoptimized-core-for-interpreter -O')], ghci_script, ['T23272.script'])
test('T23567', [extra_files(['T23567A.hs'])], multimod_compile, ['T23567', '-O -v0'])
+test('DsSpecPragmas', normal, compile, ['-O -ddump-rules'])
# The -ddump-simpl of T22404 should have no let-bindings
test('T22404', [only_ways(['optasm']), check_errmsg(r'let') ], compile, ['-ddump-simpl -dsuppress-uniques'])
=====================================
testsuite/tests/typecheck/should_compile/all.T
=====================================
@@ -738,6 +738,7 @@ test('ExplicitSpecificityA1', normal, compile, [''])
test('ExplicitSpecificityA2', normal, compile, [''])
test('ExplicitSpecificity4', normal, compile, [''])
test('RuleEqs', normal, compile, [''])
+test('SpecPragmas', normal, compile, [''])
test('T17775-viewpats-a', normal, compile, [''])
test('T17775-viewpats-b', normal, compile_fail, [''])
test('T17775-viewpats-c', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ffae48ccd1f48284f676e2c1f4b7f2ad9893ab4
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2ffae48ccd1f48284f676e2c1f4b7f2ad9893ab4
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/20250128/b1ea3a10/attachment-0001.html>
More information about the ghc-commits
mailing list