[Git][ghc/ghc][wip/T24359] More improvements
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Tue Nov 26 17:09:55 UTC 2024
Simon Peyton Jones pushed to branch wip/T24359 at Glasgow Haskell Compiler / GHC
Commits:
8a1e9b60 by Simon Peyton Jones at 2024-11-26T17:09:21+00:00
More improvements
Pretty much done except for TH stuff
- - - - -
17 changed files:
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/TyCo/FVs.hs
- compiler/GHC/Driver/Config.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr
- testsuite/tests/parser/should_fail/T7848.stderr
- testsuite/tests/simplCore/should_compile/T15445.stderr
- testsuite/tests/simplCore/should_compile/T4398.stderr
- + testsuite/tests/simplCore/should_fail/T25117a.hs
- + testsuite/tests/simplCore/should_fail/T25117a.stderr
- + testsuite/tests/simplCore/should_fail/T25117b.hs
- + testsuite/tests/simplCore/should_fail/T25117b.stderr
- testsuite/tests/simplCore/should_fail/all.T
Changes:
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -631,6 +631,9 @@ Notes:
doing this if there are no RULES; and other things being
equal it delays optimisation to delay inlining (#17409)
+* There can be a subtle order-dependency, as described in #25526;
+ it may matter whether we end up with f=g or g=f.
+
---- Historical note ---
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -360,11 +360,17 @@ data ArgSpec
-- Coercion is optimised
instance Outputable ArgInfo where
- ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds })
+ ppr (ArgInfo { ai_fun = fun, ai_args = args, ai_dmds = dmds, ai_rewrite = rewrite })
= text "ArgInfo" <+> braces
(sep [ text "fun =" <+> ppr fun
, text "dmds(first 10) =" <+> ppr (take 10 dmds)
- , text "args =" <+> ppr args ])
+ , text "args =" <+> ppr args
+ , text "rewrite =" <+> ppr rewrite ])
+
+instance Outputable RewriteCall where
+ ppr (TryRules ac _rules) = text "TryRules" <+> ppr ac
+ ppr TryInlining = text "TryInlining"
+ ppr TryNothing = text "TryNothing"
instance Outputable ArgSpec where
ppr (ValArg { as_arg = arg }) = text "ValArg" <+> ppr arg
@@ -449,7 +455,7 @@ mkRewriteCall :: Id -> RuleEnv -> RewriteCall
mkRewriteCall fun rule_env
| not (null rules) = TryRules n_required rules
| canUnfold unf = TryInlining
- | otherwise = TryNothing
+ | otherwise = pprTrace "mkRewriteCall" (ppr fun) TryNothing
where
n_required = maximum (map ruleArity rules)
rules = getRules rule_env fun
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -8,7 +8,7 @@ module GHC.Core.SimpleOpt (
SimpleOpts (..), defaultSimpleOpts,
-- ** Simple expression optimiser
- simpleOptPgm, simpleOptExpr, simpleOptExprNoOccAnal, simpleOptExprWith,
+ simpleOptPgm, simpleOptExpr, simpleOptExprNoInline, simpleOptExprWith,
-- ** Join points
joinPointBinding_maybe, joinPointBindings_maybe,
@@ -96,6 +96,8 @@ data SimpleOpts = SimpleOpts
{ so_uf_opts :: !UnfoldingOpts -- ^ Unfolding options
, so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
, so_eta_red :: !Bool -- ^ Eta reduction on?
+ , so_inline :: !Bool -- ^ False <=> do no inlining whatsoever,
+ -- even for trivial or used-once things
}
-- | Default options for the Simple optimiser.
@@ -104,6 +106,7 @@ defaultSimpleOpts = SimpleOpts
{ so_uf_opts = defaultUnfoldingOpts
, so_co_opts = OptCoercionOpts { optCoercionEnabled = False }
, so_eta_red = False
+ , so_inline = True
}
simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
@@ -146,13 +149,15 @@ simpleOptExpr opts expr
-- It's a bit painful to call exprFreeVars, because it makes
-- three passes instead of two (occ-anal, and go)
-simpleOptExprNoOccAnal :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
--- A variant of simpleOptExpr but without occurrence analysis
+simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
+-- A variant of simpleOptExpr, but without
+-- occurrence analysis or inlining of any kind.
-- Result: we don't inline evidence bindings, which is useful for the specialiser
-simpleOptExprNoOccAnal opts expr
+simpleOptExprNoInline opts expr
= simple_opt_expr init_env expr
where
- init_env = (emptyEnv opts) { soe_subst = init_subst }
+ init_opts = opts { so_inline = False }
+ init_env = (emptyEnv init_opts) { soe_subst = init_subst }
init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
simpleOptExprWith :: HasDebugCallStack => SimpleOpts -> Subst -> InExpr -> OutExpr
@@ -464,7 +469,7 @@ simple_bind_pair :: SimpleOptEnv
-- (simple_bind_pair subst in_var out_rhs)
-- either extends subst with (in_var -> out_rhs)
-- or returns Nothing
-simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
+simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opts })
in_bndr mb_out_bndr clo@(rhs_env, in_rhs)
top_level
| Type ty <- in_rhs -- let a::* = TYPE ty in <body>
@@ -506,6 +511,7 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst })
pre_inline_unconditionally :: Bool
pre_inline_unconditionally
+ | not (so_inline opts) = False -- Not if so_inline is False
| isExportedId in_bndr = False
| stable_unf = False
| not active = False -- Note [Inline prag in simplOpt]
@@ -557,13 +563,14 @@ simple_out_bind_pair :: SimpleOptEnv
-> InId -> Maybe OutId -> OutExpr
-> OccInfo -> Bool -> Bool -> TopLevelFlag
-> (SimpleOptEnv, Maybe (OutVar, OutExpr))
-simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
+simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts })
+ in_bndr mb_out_bndr out_rhs
occ_info active stable_unf top_level
| assertPpr (isNonCoVarId in_bndr) (ppr in_bndr)
-- Type and coercion bindings are caught earlier
-- See Note [Core type and coercion invariant]
post_inline_unconditionally
- = ( env' { soe_subst = extendIdSubst (soe_subst env) in_bndr out_rhs }
+ = ( env' { soe_subst = extendIdSubst subst in_bndr out_rhs }
, Nothing)
| otherwise
@@ -576,6 +583,7 @@ simple_out_bind_pair env in_bndr mb_out_bndr out_rhs
post_inline_unconditionally :: Bool
post_inline_unconditionally
+ | not (so_inline opts) = False -- Not if so_inline is False
| isExportedId in_bndr = False -- Note [Exported Ids and trivial RHSs]
| stable_unf = False -- Note [Stable unfoldings and postInlineUnconditionally]
| not active = False -- in GHC.Core.Opt.Simplify.Utils
@@ -848,7 +856,7 @@ too. Achieving all this is surprisingly tricky:
(MC1) We must compulsorily unfold MkAge to a cast.
See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make
-(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding
+(MC2) We must compulsorily unfold coerce on the rule LHS, yielding
forall a b (dict :: Coercible * a b).
map @a @b (\(x :: a) -> case dict of
MkCoercible (co :: a ~R# b) -> x |> co) = ...
@@ -865,7 +873,6 @@ too. Achieving all this is surprisingly tricky:
Unfortunately, this still abstracts over a Coercible dictionary. We really
want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,
which transforms the above to
- Desugar)
forall a b (co :: a ~R# b).
let dict = MkCoercible @* @a @b co in
@@ -890,7 +897,7 @@ too. Achieving all this is surprisingly tricky:
(MC4) The map/coerce rule is the only compelling reason for having a RULE that
quantifies over a coercion variable, something that is otherwise Very Deeply
- Suspicous. See Note [Casts in the template] in GHC.Core.Rules. Ugh!
+ Suspicious. See Note [Casts in the template] in GHC.Core.Rules. Ugh!
This is all a fair amount of special-purpose hackery, but it's for
a good cause. And it won't hurt other RULES and such that it comes across.
=====================================
compiler/GHC/Core/TyCo/FVs.hs
=====================================
@@ -1043,41 +1043,44 @@ types/kinds are fully settled and zonked.
-- be reordered unnecessarily. This is specified in Note [ScopedSort]
-- See also Note [Ordering of implicit variables] in "GHC.Rename.HsType"
-scopedSort :: [TyCoVar] -> [TyCoVar]
+scopedSort :: [Var] -> [Var]
scopedSort = go [] []
where
- go :: [TyCoVar] -- already sorted, in reverse order
+ go :: [Var] -- already sorted, in reverse order
-> [TyCoVarSet] -- each set contains all the variables which must be placed
-- before the tv corresponding to the set; they are accumulations
- -- of the fvs in the sorted tvs' kinds
+ -- of the fvs in the sorted Var's types
- -- This list is in 1-to-1 correspondence with the sorted tyvars
+ -- This list is in 1-to-1 correspondence with the sorted Vars
-- INVARIANT:
-- all (\tl -> all (`subVarSet` head tl) (tail tl)) (tails fv_list)
-- That is, each set in the list is a superset of all later sets.
- -> [TyCoVar] -- yet to be sorted
- -> [TyCoVar]
+ -> [Var] -- yet to be sorted
+ -> [Var]
go acc _fv_list [] = reverse acc
go acc fv_list (tv:tvs)
= go acc' fv_list' tvs
where
(acc', fv_list') = insert tv acc fv_list
- insert :: TyCoVar -- var to insert
- -> [TyCoVar] -- sorted list, in reverse order
+ insert :: Var -- var to insert
+ -> [Var] -- sorted list, in reverse order
-> [TyCoVarSet] -- list of fvs, as above
- -> ([TyCoVar], [TyCoVarSet]) -- augmented lists
- insert tv [] [] = ([tv], [tyCoVarsOfType (tyVarKind tv)])
- insert tv (a:as) (fvs:fvss)
- | tv `elemVarSet` fvs
- , (as', fvss') <- insert tv as fvss
- = (a:as', fvs `unionVarSet` fv_tv : fvss')
-
- | otherwise
- = (tv:a:as, fvs `unionVarSet` fv_tv : fvs : fvss)
+ -> ([Var], [TyCoVarSet]) -- augmented lists
+ -- Generally we put the new Var at the front of the accumulating list
+ -- (leading to a stable sort) unless there is are reason to put it later.
+ insert v [] [] = ([v], [tyCoVarsOfType (varType v)])
+ insert v (a:as) (fvs:fvss)
+ | (isTyVar v && isId a) || (v `elemVarSet` fvs)
+ -- (a) put Ids after TyVars, and (b) respect dependencies
+ , (as', fvss') <- insert v as fvss
+ = (a:as', fvs `unionVarSet` fv_v : fvss')
+
+ | otherwise -- Put `v` at the front
+ = (v:a:as, fvs `unionVarSet` fv_v : fvs : fvss)
where
- fv_tv = tyCoVarsOfType (tyVarKind tv)
+ fv_v = tyCoVarsOfType (varType v)
-- lists not in correspondence
insert _ _ _ = panic "scopedSort"
=====================================
compiler/GHC/Driver/Config.hs
=====================================
@@ -25,6 +25,7 @@ initSimpleOpts dflags = SimpleOpts
{ so_uf_opts = unfoldingOpts dflags
, so_co_opts = initOptCoercionOpts dflags
, so_eta_red = gopt Opt_DoEtaReduction dflags
+ , so_inline = True
}
-- | Extract GHCi options from DynFlags and step
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -809,9 +809,6 @@ dsSpec :: CoreExpr -- RHS to be specialised
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)
-- SpecPrag case: See Note [Handling old-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
- | isJust (isClassOpId_maybe poly_id)
- = failBecauseOfClassOp poly_id
-
| (spec_bndrs, spec_app) <- collectHsWrapBinders spec_co
-- spec_co looks like
-- \spec_bndrs. [] spec_args
@@ -826,53 +823,6 @@ dsSpec poly_rhs (SpecPrag poly_id spec_co spec_inl)
finishSpecPrag poly_rhs rule_bndrs poly_id rule_lhs_args
rule_bndrs core_app spec_inl } }
-{-
-dsSpec mb_poly_rhs (SpecPragE { spe_poly_id = poly_id
- , spe_tv_bndrs = tv_bndrs
- , spe_id_bndrs = id_bndrs
- , spe_lhs_ev_bndrs = lhs_evs
- , spe_lhs_binds = lhs_binds
- , spe_lhs_call = the_call
- , spe_rhs_ev_bndrs = rhs_evs
- , spe_rhs_binds = rhs_binds
- , spe_inl = inl })
- -- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
- | isJust (isClassOpId_maybe poly_id)
- = failBecauseOfClassOp poly_id
-
- | otherwise
- = dsTcEvBinds lhs_binds $ \ ds_lhs_binds ->
- dsTcEvBinds rhs_binds $ \ ds_rhs_binds ->
- do { dflags <- getDynFlags
- ; ds_call <- zapUnspecables $
- -- zapUnspecables: see Note [Desugaring RULE left hand sides]
- dsLExpr the_call
- ; tracePm "dsSpec1" (vcat
- [ ppr poly_id
- , text "lhs_binds" <+> ppr lhs_binds
- , text "ds_lhs_binds" <+> ppr ds_lhs_binds
- , text "ds_call" <+> ppr ds_call ])
-
- ; let simpl_opts = initSimpleOpts dflags
- core_call = mkLets ds_lhs_binds $
- drop_cast $
- simpleOptExpr simpl_opts $
- ds_call
-
- mk_spec_call fn_body lhs_args
- = mkLets ds_rhs_binds $
- mkCoreApps fn_body lhs_args
-
- ; tracePm "dsSpec1" (vcat [ ppr poly_id $$ ppr ds_call $$ ppr core_call])
- ; finishSpecPrag mb_poly_rhs
- (tv_bndrs ++ lhs_evs ++ id_bndrs) core_call
- (tv_bndrs ++ rhs_evs ++ id_bndrs) mk_spec_call
- inl }
- where
- drop_cast (Cast e _) = drop_cast e
- drop_cast e = e
--}
-
dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
, spe_tv_bndrs = tv_bndrs
, spe_id_bndrs = id_bndrs
@@ -880,13 +830,9 @@ dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
, spe_call = the_call
, spe_inl = inl })
-- SpecPragE case: See Note [Handling new-form SPECIALISE pragmas] in GHC.Tc.Gen.Sig
- | isJust (isClassOpId_maybe poly_id)
- = failBecauseOfClassOp poly_id
+ = do { ds_call <- zapUnspecables $ -- zapUnspecables: see
+ dsLExpr the_call -- Note [Desugaring RULE left hand sides]
- | otherwise
- = do { ds_call <- zapUnspecables $
- -- zapUnspecables: see Note [Desugaring RULE left hand sides]
- dsLExpr the_call
; tracePm "dsSpec1" (vcat
[ ppr poly_id
, text "tv_bndrs" <+> ppr tv_bndrs
@@ -894,16 +840,13 @@ dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
; dflags <- getDynFlags
; let simpl_opts = initSimpleOpts dflags
- core_call = simpleOptExprNoOccAnal simpl_opts ds_call
-
- ; case prepareSpecLHS lhs_evs core_call of {
+ core_call = simpleOptExprNoInline simpl_opts ds_call
+ ; case prepareSpecLHS poly_id lhs_evs core_call of {
Nothing -> do { diagnosticDs (DsRuleLhsTooComplicated ds_call core_call)
; return Nothing } ;
- Just (qevs, rhs_const_binds, fn_id, lhs_args) ->
-
+ Just (qevs, rhs_const_binds, lhs_args) ->
- assertPpr (fn_id == poly_id) (ppr fn_id $$ ppr poly_id) $
do { let lhs_id_bndrs = mkVarSet id_bndrs `unionVarSet`
qevs `unionVarSet`
mkVarSet (bindersOfBinds rhs_const_binds)
@@ -937,14 +880,15 @@ dsSpec poly_rhs (SpecPragE { spe_poly_id = poly_id
rule_bndrs poly_id lhs_args
spec_bndrs mk_spec_body inl } } }
-prepareSpecLHS :: [EvVar] -> CoreExpr -> Maybe (VarSet, [CoreBind], Id, [CoreExpr])
-prepareSpecLHS evs the_call
+prepareSpecLHS :: Id -> [EvVar] -> CoreExpr
+ -> Maybe (VarSet, [CoreBind], [CoreExpr])
+prepareSpecLHS poly_id evs the_call
= go (mkVarSet evs) [] the_call
where
go :: VarSet
-> [CoreBind] -- Reversed list of constant evidence bindings
-> CoreExpr
- -> Maybe (IdSet, [CoreBind], Id, [CoreExpr])
+ -> Maybe (IdSet, [CoreBind], [CoreExpr])
go qevs acc (Cast e _)
= go qevs acc e
go qevs acc (Let bind e)
@@ -960,24 +904,29 @@ prepareSpecLHS evs the_call
go qevs acc e
| (Var fun, args) <- collectArgs e
- = Just (qevs, reverse acc, fun, args)
+ = assertPpr (fun == poly_id) (ppr fun $$ ppr poly_id) $
+ Just (qevs, reverse acc, args)
| otherwise
= Nothing
-failBecauseOfClassOp :: Id -> DsM (Maybe a)
--- There is no point in trying to specialise a class op
--- Moreover, classops don't (currently) have an inl_sat arity set
--- (it would be Just 0) and that in turn makes makeCorePair bleat
-failBecauseOfClassOp poly_id
- = do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
- ; return Nothing }
-
finishSpecPrag :: CoreExpr -- RHS to specialise
-> [Var] -> Id -> [CoreExpr] -- RULE LHS pattern
-> [Var] -> (CoreExpr -> CoreExpr) -> InlinePragma -- Specialised form
-> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule))
finishSpecPrag poly_rhs rule_bndrs poly_id rule_args
spec_bndrs mk_spec_body spec_inl
+ | isJust (isClassOpId_maybe poly_id)
+ = do { diagnosticDs (DsUselessSpecialiseForClassMethodSelector poly_id)
+ ; return Nothing } -- There is no point in trying to specialise a class op
+ -- Moreover, classops don't (currently) have an inl_sat arity set
+ -- (it would be Just 0) and that in turn makes makeCorePair bleat
+
+ | no_act_spec && isNeverActive rule_act
+ = do { diagnosticDs (DsUselessSpecialiseForNoInlineFunction poly_id)
+ ; return Nothing } -- Function is NOINLINE, and the specialisation inherits that
+ -- See Note [Activation pragmas for SPECIALISE]
+
+ | otherwise
-- The RULE looks like
-- RULE "USPEC" forall rule_bndrs. f rule_args = $sf spec_bndrs
-- The specialised function looks like
@@ -990,16 +939,13 @@ finishSpecPrag poly_rhs rule_bndrs poly_id rule_args
; let poly_name = idName poly_id
spec_occ = mkSpecOcc (getOccName poly_name)
spec_name = mkInternalName uniq spec_occ (getSrcSpan poly_name)
- id_inl = idInlinePragma poly_id
- inl_prag = specFunInlinePrag poly_id id_inl spec_inl
- rule_act = specRuleActivation id_inl spec_inl
simpl_opts = initSimpleOpts dflags
fn_unf = realIdUnfolding poly_id
spec_unf = specUnfolding simpl_opts spec_bndrs mk_spec_body rule_args fn_unf
spec_id = mkLocalId spec_name ManyTy spec_ty
-- Specialised binding is toplevel, hence Many.
- `setInlinePragma` inl_prag
+ `setInlinePragma` specFunInlinePrag poly_id id_inl spec_inl
`setIdUnfolding` spec_unf
rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
@@ -1021,6 +967,19 @@ finishSpecPrag poly_rhs rule_bndrs poly_id rule_args
-- makeCorePair overwrites the unfolding, which we have
-- just created using specUnfolding
}
+ where
+ -- See Note [Activation pragmas for SPECIALISE]
+ -- no_act_spec is True if the user didn't write an explicit
+ -- phase specification in the SPECIALISE pragma
+ id_inl = idInlinePragma poly_id
+ inl_prag_act = inlinePragmaActivation id_inl
+ spec_prag_act = inlinePragmaActivation spec_inl
+ no_act_spec = case inlinePragmaSpec spec_inl of
+ NoInline _ -> isNeverActive spec_prag_act
+ Opaque _ -> isNeverActive spec_prag_act
+ _ -> isAlwaysActive spec_prag_act
+ rule_act | no_act_spec = inl_prag_act -- Inherit
+ | otherwise = spec_prag_act -- Specified by user
specFunInlinePrag :: Id -> InlinePragma
-> InlinePragma -> InlinePragma
@@ -1034,21 +993,6 @@ specFunInlinePrag poly_id id_inl spec_inl
-- Get the INLINE pragma from SPECIALISE declaration, or,
-- failing that, from the original Id
-specRuleActivation :: InlinePragma -> InlinePragma -> Activation
-specRuleActivation id_inl spec_inl
- | no_act_spec = inl_prag_act -- Inherit
- | otherwise = spec_prag_act -- Specified by user
- where
- -- See Note [Activation pragmas for SPECIALISE]
- -- no_act_spec is True if the user didn't write an explicit
- -- phase specification in the SPECIALISE pragma
- inl_prag_act = inlinePragmaActivation id_inl
- spec_prag_act = inlinePragmaActivation spec_inl
- no_act_spec = case inlinePragmaSpec spec_inl of
- NoInline _ -> isNeverActive spec_prag_act
- Opaque _ -> isNeverActive spec_prag_act
- _ -> isAlwaysActive spec_prag_act
-
dsWarnOrphanRule :: CoreRule -> DsM ()
dsWarnOrphanRule rule
= when (ruleIsOrphan rule) $
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -696,8 +696,7 @@ ds_app (XExpr (HsRecSelTc (FieldOcc { foLabel = L _ sel_id }))) _hs_args core_ar
= ds_app_rec_sel sel_id sel_id core_args
ds_app (HsVar _ lfun) hs_args core_args
- = do { tracePm "ds_app" (ppr lfun <+> ppr core_args)
- ; ds_app_var lfun hs_args core_args }
+ = ds_app_var lfun hs_args core_args
ds_app e _hs_args core_args
= do { core_e <- dsExpr e
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1397,7 +1397,7 @@ instance Diagnostic TcRnMessage where
where
sigs = sig1 : sig2 : otherSigs
TcRnSpecSigShape spec_e -> mkSimpleDecorated $
- hang (text "Illegal form of SPECIALISE pragma")
+ hang (text "Illegal form of SPECIALISE pragma:")
2 (ppr spec_e)
TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $
text "Illegal standalone deriving declaration"
=====================================
testsuite/tests/parser/should_compile/OpaqueParseWarn1.stderr
=====================================
@@ -1,3 +1,3 @@
-
OpaqueParseWarn1.hs:6:1: warning: [GHC-38524]
Ignoring useless SPECIALISE pragma for NOINLINE function: ‘f’
+
=====================================
testsuite/tests/parser/should_fail/T7848.stderr
=====================================
@@ -1,11 +1,10 @@
-
-T7848.hs:10:9: error: [GHC-25897]
- • Couldn't match expected type ‘Char’ with actual type ‘a’
+T7848.hs:10:24: error: [GHC-25897]
+ • Couldn't match expected type ‘a’ with actual type ‘Char’
‘a’ is a rigid type variable bound by
- the type signature for:
- (&) :: forall a. a
- at T7848.hs:10:9-35
- • In the pragma: {-# SPECIALIZE (&) :: a #-}
+ an expression type signature:
+ forall a. a
+ at T7848.hs:10:31
+ • In the expression: (&) :: a
In an equation for ‘x’:
x (+) ((&)@z) ((:&&) a b) (c :&& d) (e `A` f) (A g h)
= y
@@ -15,3 +14,4 @@ T7848.hs:10:9: error: [GHC-25897]
{-# INLINE (&) #-}
{-# SPECIALIZE (&) :: a #-}
(&) = 'c'
+
=====================================
testsuite/tests/simplCore/should_compile/T15445.stderr
=====================================
@@ -8,6 +8,7 @@ Rule fired: Class op show (BUILTIN)
Rule fired: USPEC plusTwoRec @Int (T15445a)
Rule fired: Class op enumFromTo (BUILTIN)
Rule fired: Class op show (BUILTIN)
+Rule fired: USPEC plusTwoRec @Int (T15445a)
Rule fired: Class op enumFromTo (BUILTIN)
Rule fired: eftIntList (GHC.Internal.Enum)
Rule fired: ># (BUILTIN)
=====================================
testsuite/tests/simplCore/should_compile/T4398.stderr
=====================================
@@ -1,6 +1,6 @@
-
T4398.hs:6:11: warning: [GHC-40548]
Forall'd constraint ‘Ord a’ is not bound in RULE lhs
Orig bndrs: [a, $dOrd, x, y]
Orig lhs: f @a ((\ ($dOrd :: Ord a) -> x) $dOrd) y
- optimised lhs: f @a x y
+ Optimised lhs: f @a x y
+
=====================================
testsuite/tests/simplCore/should_fail/T25117a.hs
=====================================
@@ -0,0 +1,6 @@
+module T25117a where
+
+f :: Ord a => a -> a
+f = f
+
+{-# SPECIALISE let x = 2 in f x #-}
=====================================
testsuite/tests/simplCore/should_fail/T25117a.stderr
=====================================
@@ -0,0 +1,2 @@
+T25117a.hs:6:1: error: [GHC-93944]
+ Illegal form of SPECIALISE pragma: let x = 2 in f x
=====================================
testsuite/tests/simplCore/should_fail/T25117b.hs
=====================================
@@ -0,0 +1,7 @@
+module T25117b where
+
+f :: Num a => a -> a
+f = f
+
+-- We don't allow old-form multiple type ascriptions
+{-# SPECIALISE forall . f :: Int->Int, Float->Float #-}
=====================================
testsuite/tests/simplCore/should_fail/T25117b.stderr
=====================================
@@ -0,0 +1,2 @@
+T25117b.hs:6:1: error: [GHC-62037]
+ SPECIALIZE expression doesn't support multiple specialize type ascriptions
=====================================
testsuite/tests/simplCore/should_fail/all.T
=====================================
@@ -1,3 +1,5 @@
test('T7411', [expect_broken_for(7411, ['optasm', 'optllvm',
'threaded2', 'dyn']),
exit_code(1)], compile_and_run, [''])
+test('T25117a', normal, compile_fail, [''])
+test('T25117b', normal, compile_fail, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a1e9b601bd61853050db3d8a783004ed0dc487c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8a1e9b601bd61853050db3d8a783004ed0dc487c
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/20241126/1a514537/attachment-0001.html>
More information about the ghc-commits
mailing list