[Git][ghc/ghc][wip/incoherent-spec-flag] 2 commits: Add flag to enable/disable incoherent instances
Gergő Érdi (@cactus)
gitlab at gitlab.haskell.org
Wed Jun 28 05:55:53 UTC 2023
Gergő Érdi pushed to branch wip/incoherent-spec-flag at Glasgow Haskell Compiler / GHC
Commits:
2922712e by Gergő Érdi at 2023-06-28T06:54:51+01:00
Add flag to enable/disable incoherent instances
Fixes #23287
- - - - -
d61f806e by Gergő Érdi at 2023-06-28T06:55:34+01:00
Desugar bindings in the context of their evidence
Closes #23172
- - - - -
9 changed files:
- compiler/GHC/Core/InstEnv.hs
- compiler/GHC/Driver/DynFlags.hs
- compiler/GHC/Driver/Flags.hs
- compiler/GHC/Driver/Session.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Monad.hs
- compiler/GHC/HsToCore/Types.hs
- compiler/GHC/Tc/Instance/Class.hs
- testsuite/tests/simplCore/should_run/T22448.hs
Changes:
=====================================
compiler/GHC/Core/InstEnv.hs
=====================================
@@ -955,7 +955,7 @@ data LookupInstanceErrReason =
LookupInstErrNotFound
deriving (Generic)
-data Coherence = IsCoherent | IsIncoherent
+data Coherence = IsCoherent | IsIncoherent | IsNoncanonical
-- See Note [Recording coherence information in `PotentialUnifiers`]
data PotentialUnifiers = NoUnifiers Coherence
@@ -983,6 +983,7 @@ potential unifiers is otherwise empty.
instance Outputable Coherence where
ppr IsCoherent = text "coherent"
ppr IsIncoherent = text "incoherent"
+ ppr IsNoncanonical = text "non-canonical"
instance Outputable PotentialUnifiers where
ppr (NoUnifiers c) = text "NoUnifiers" <+> ppr c
@@ -990,6 +991,8 @@ instance Outputable PotentialUnifiers where
instance Semigroup Coherence where
IsCoherent <> IsCoherent = IsCoherent
+ IsNoncanonical <> _ = IsNoncanonical
+ _ <> IsNoncanonical = IsNoncanonical
_ <> _ = IsIncoherent
instance Semigroup PotentialUnifiers where
=====================================
compiler/GHC/Driver/DynFlags.hs
=====================================
@@ -1187,7 +1187,8 @@ defaultFlags settings
Opt_CompactUnwind,
Opt_ShowErrorContext,
Opt_SuppressStgReps,
- Opt_UnoptimizedCoreForInterpreter
+ Opt_UnoptimizedCoreForInterpreter,
+ Opt_SpecIncoherents
]
++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns]
=====================================
compiler/GHC/Driver/Flags.hs
=====================================
@@ -266,6 +266,7 @@ data GeneralFlag
| Opt_LiberateCase
| Opt_SpecConstr
| Opt_SpecConstrKeen
+ | Opt_SpecIncoherents
| Opt_DoLambdaEtaExpansion
| Opt_IgnoreAsserts
| Opt_DoEtaReduction
=====================================
compiler/GHC/Driver/Session.hs
=====================================
@@ -2429,6 +2429,7 @@ fFlagsDeps = [
flagSpec "specialize-aggressively" Opt_SpecialiseAggressively,
flagSpec "cross-module-specialise" Opt_CrossModuleSpecialise,
flagSpec "cross-module-specialize" Opt_CrossModuleSpecialise,
+ flagSpec "spec-incoherents" Opt_SpecIncoherents,
flagSpec "inline-generics" Opt_InlineGenerics,
flagSpec "inline-generics-aggressively" Opt_InlineGenericsAggressively,
flagSpec "static-argument-transformation" Opt_StaticArgumentTransformation,
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -205,16 +205,15 @@ dsHsBind
, abs_exports = exports
, abs_ev_binds = ev_binds
, abs_binds = binds, abs_sig = has_sig }))
- = do { ds_binds <- addTyCs FromSource (listToBag dicts) $
- dsLHsBinds binds
- -- addTyCs: push type constraints deeper
- -- for inner pattern match check
- -- See Check, Note [Long-distance information]
+ = dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do
+ { ds_binds <- addTyCs FromSource (listToBag dicts) $
+ dsLHsBinds binds
+ -- addTyCs: push type constraints deeper
+ -- for inner pattern match check
+ -- See Check, Note [Long-distance information]
- ; dsTcEvBinds_s ev_binds $ \ds_ev_binds -> do
-
- -- dsAbsBinds does the hard work
- { dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig } }
+ -- dsAbsBinds does the hard work
+ ; dsAbsBinds dflags tyvars dicts exports ds_ev_binds ds_binds has_sig }
dsHsBind _ (PatSynBind{}) = panic "dsHsBind: PatSynBind"
@@ -1202,20 +1201,24 @@ dsHsWrapper (WpFun c1 c2 (Scaled w t1)) k -- See Note [Desugaring WpFun]
dsHsWrapper (WpCast co) k = assert (coercionRole co == Representational) $
k $ \e -> mkCastDs e co
dsHsWrapper (WpEvApp tm) k = do { core_tm <- dsEvTerm tm
- ; incoherents <- getIncoherents
+ ; unspecables <- getUnspecables
+ -- ; spec_incoherents <- getSpecIncoherents
; let vs = exprFreeVarsList core_tm
- is_incoherent_var v = v `S.member` incoherents
- is_coherent = all (not . is_incoherent_var) vs -- See Note [Desugaring incoherent evidence]
- ; k (\e -> app_ev is_coherent e core_tm) }
+ is_unspecable_var v = v `S.member` unspecables
+ is_specable = not $ any (is_unspecable_var) vs -- See Note [Desugaring incoherent evidence]
+ ; k (\e -> app_ev is_specable e core_tm) }
-- See Note [Wrapper returned from tcSubMult] in GHC.Tc.Utils.Unify.
dsHsWrapper (WpMultCoercion co) k = do { unless (isReflexiveCo co) $
diagnosticDs DsMultiplicityCoercionsNotSupported
; k $ \e -> e }
app_ev :: Bool -> CoreExpr -> CoreExpr -> CoreExpr
-app_ev is_coherent k core_tm
- | is_coherent = k `App` core_tm
- | otherwise = Var nospecId `App` Type (exprType k) `App` k `App` core_tm
+app_ev is_specable k core_tm
+ | not is_specable
+ = Var nospecId `App` Type (exprType k) `App` k `App` core_tm
+
+ | otherwise
+ = k `App` core_tm
dsHsWrappers :: [HsWrapper] -> ([CoreExpr -> CoreExpr] -> DsM a) -> DsM a
dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps -> k (wrap:wraps)
@@ -1237,40 +1240,46 @@ dsTcEvBinds (EvBinds bs) = dsEvBinds bs
-- for each binder in ev_binds, before invoking thing_inside
dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
dsEvBinds ev_binds thing_inside
+ = do { spec_incoherents <- getSpecIncoherents
+ ; ds_ev_binds spec_incoherents ev_binds thing_inside }
+
+ds_ev_binds :: Bool -> Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
+ds_ev_binds spec_incoherents ev_binds thing_inside
= do { ds_binds <- mapBagM dsEvBind ev_binds
; let comps = sort_ev_binds ds_binds
; go comps thing_inside }
where
go ::[SCC (Node EvVar (Coherence, CoreExpr))] -> ([CoreBind] -> DsM a) -> DsM a
go (comp:comps) thing_inside
- = do { incoherents <- getIncoherents
- ; let (core_bind, new_incoherents) = ds_component incoherents comp
- ; addIncoherents new_incoherents $ go comps $ \ core_binds -> thing_inside (core_bind:core_binds) }
+ = do { unspecables <- getUnspecables
+ ; let (core_bind, new_unspecables) = ds_component unspecables comp
+ ; addUnspecables new_unspecables $ go comps $ \ core_binds -> thing_inside (core_bind:core_binds) }
go [] thing_inside = thing_inside []
- is_coherent IsCoherent = True
- is_coherent IsIncoherent = False
+ is_specable IsCoherent = True
+ is_specable IsIncoherent = spec_incoherents
+ is_specable IsNoncanonical = False
- ds_component incoherents (AcyclicSCC node) = (NonRec v rhs, new_incoherents)
+ ds_component unspecables (AcyclicSCC node) = (NonRec v rhs, new_unspecables)
where
((v, rhs), (this_coherence, deps)) = unpack_node node
- transitively_incoherent = not (is_coherent this_coherence) || any is_incoherent deps
- is_incoherent dep = dep `S.member` incoherents
- new_incoherents
- | transitively_incoherent = S.singleton v
+ transitively_unspecable = not (is_specable this_coherence) || any is_unspecable deps
+ is_unspecable dep = dep `S.member` unspecables
+ new_unspecables
+ | transitively_unspecable = S.singleton v
| otherwise = mempty
- ds_component incoherents (CyclicSCC nodes) = (Rec pairs, new_incoherents)
+ ds_component unspecables (CyclicSCC nodes) = (Rec pairs, new_unspecables)
where
(pairs, direct_coherence) = unzip $ map unpack_node nodes
- is_incoherent_remote dep = dep `S.member` incoherents
- transitively_incoherent = or [ not (is_coherent this_coherence) || any is_incoherent_remote deps | (this_coherence, deps) <- direct_coherence ]
- -- Bindings from a given SCC are transitively coherent if
- -- all are coherent and all their remote dependencies are
- -- also coherent; see Note [Desugaring incoherent evidence]
+ is_unspecable_remote dep = dep `S.member` unspecables
+ transitively_unspecable = or [ not (is_specable this_coherence) || any is_unspecable_remote deps | (this_coherence, deps) <- direct_coherence ]
+ -- Bindings from a given SCC are transitively specialisable if
+ -- all are specialisable and all their remote dependencies are
+ -- also specialisable; see Note [Desugaring incoherent evidence]
- new_incoherents
- | transitively_incoherent = S.fromList [ v | (v, _) <- pairs]
+ new_unspecables
+ | transitively_unspecable = S.fromList [ v | (v, _) <- pairs]
| otherwise = mempty
unpack_node DigraphNode { node_key = v, node_payload = (coherence, rhs), node_dependencies = deps } = ((v, rhs), (coherence, deps))
=====================================
compiler/GHC/HsToCore/Monad.hs
=====================================
@@ -37,7 +37,7 @@ module GHC.HsToCore.Monad (
getPmNablas, updPmNablas,
-- Tracking evidence variable coherence
- addIncoherents, getIncoherents,
+ getSpecIncoherents, addUnspecables, getUnspecables,
-- Get COMPLETE sets of a TyCon
dsGetCompleteMatches,
@@ -248,8 +248,10 @@ mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
++ eps_complete_matches eps -- from imports
-- re-use existing next_wrapper_num to ensure uniqueness
next_wrapper_num_var = tcg_next_wrapper_num tcg_env
+ spec_incoherents = gopt Opt_SpecIncoherents (hsc_dflags hsc_env)
; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env ptc
msg_var cc_st_var next_wrapper_num_var complete_matches
+ spec_incoherents
}
runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
@@ -282,6 +284,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
complete_matches = hptCompleteSigs hsc_env -- from the home package
++ local_complete_matches -- from the current module
++ eps_complete_matches eps -- from imports
+ spec_incoherents = gopt Opt_SpecIncoherents (hsc_dflags hsc_env)
bindsToIds (NonRec v _) = [v]
bindsToIds (Rec binds) = map fst binds
@@ -290,6 +293,7 @@ initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
envs = mkDsEnvs unit_env this_mod rdr_env type_env
fam_inst_env ptc msg_var cc_st_var
next_wrapper_num complete_matches
+ spec_incoherents
; runDs hsc_env envs thing_inside
}
@@ -330,9 +334,10 @@ mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
-> PromotionTickContext
-> IORef (Messages DsMessage) -> IORef CostCentreState
-> IORef (ModuleEnv Int) -> CompleteMatches
+ -> Bool
-> (DsGblEnv, DsLclEnv)
mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
- next_wrapper_num complete_matches
+ next_wrapper_num complete_matches spec_incoherents
= let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
-- Failing tests here are `ghci` and `T11985` if you get this wrong.
-- this is very very "at a distance" because the reason for this check is that the type_env in interactive
@@ -353,11 +358,12 @@ mkDsEnvs unit_env mod rdr_env type_env fam_inst_env ptc msg_var cc_st_var
, ds_complete_matches = complete_matches
, ds_cc_st = cc_st_var
, ds_next_wrapper_num = next_wrapper_num
+ , ds_spec_incoherents = spec_incoherents
}
lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
, dsl_loc = real_span
, dsl_nablas = initNablas
- , dsl_incoherents = mempty
+ , dsl_unspecables = mempty
}
in (gbl_env, lcl_env)
@@ -413,11 +419,11 @@ getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
updPmNablas :: Nablas -> DsM a -> DsM a
updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
-addIncoherents :: S.Set EvId -> DsM a -> DsM a
-addIncoherents incoherents = updLclEnv (\env -> env{ dsl_incoherents = incoherents `mappend` dsl_incoherents env })
+addUnspecables :: S.Set EvId -> DsM a -> DsM a
+addUnspecables unspecables = updLclEnv (\env -> env{ dsl_unspecables = unspecables `mappend` dsl_unspecables env })
-getIncoherents :: DsM (S.Set EvId)
-getIncoherents = dsl_incoherents <$> getLclEnv
+getUnspecables :: DsM (S.Set EvId)
+getUnspecables = dsl_unspecables <$> getLclEnv
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv
@@ -523,6 +529,9 @@ discardWarningsDs thing_inside
; return result }
+getSpecIncoherents :: DsM Bool
+getSpecIncoherents = ds_spec_incoherents <$> getGblEnv
+
-- | Inject a trace message into the compiled program. Whereas
-- pprTrace prints out information *while compiling*, pprRuntimeTrace
-- captures that information and causes it to be printed *at runtime*
=====================================
compiler/GHC/HsToCore/Types.hs
=====================================
@@ -11,7 +11,7 @@ module GHC.HsToCore.Types (
DsMetaEnv, DsMetaVal(..), CompleteMatches
) where
-import GHC.Prelude (Int)
+import GHC.Prelude (Int, Bool)
import Data.IORef
import qualified Data.Set as S
@@ -65,6 +65,8 @@ data DsGblEnv
-- Tracking indices for cost centre annotations
, ds_next_wrapper_num :: IORef (ModuleEnv Int)
-- ^ See Note [Generating fresh names for FFI wrappers]
+
+ , ds_spec_incoherents :: Bool
}
instance ContainsModule DsGblEnv where
@@ -79,9 +81,9 @@ data DsLclEnv
-- ^ See Note [Long-distance information] in "GHC.HsToCore.Pmc".
-- The set of reaching values Nablas is augmented as we walk inwards, refined
-- through each pattern match in turn
- , dsl_incoherents :: S.Set EvVar
+ , dsl_unspecables :: S.Set EvVar
-- ^ See Note [Desugaring incoherent evidence]: this field collects
- -- all incoherent evidence variables in scope.
+ -- all un-specialisable evidence variables in scope.
}
-- Inside [| |] brackets, the desugarer looks
=====================================
compiler/GHC/Tc/Instance/Class.hs
=====================================
@@ -448,7 +448,7 @@ matchWithDict [cls, mty]
; return $ OneInst { cir_new_theta = [mkPrimEqPred mty inst_meth_ty]
, cir_mk_ev = mk_ev
- , cir_coherence = IsIncoherent -- See (WD6) in Note [withDict]
+ , cir_coherence = IsNoncanonical -- See (WD6) in Note [withDict]
, cir_what = BuiltinInstance }
}
=====================================
testsuite/tests/simplCore/should_run/T22448.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE MonoLocalBinds #-}
+{-# OPTIONS_GHC -fno-spec-incoherents #-}
class C a where
op :: a -> String
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74306ea72b3a0e42a48409c73517b626543370a9...d61f806e74f823dbc577d0e702d7bf601be7f10c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/74306ea72b3a0e42a48409c73517b626543370a9...d61f806e74f823dbc577d0e702d7bf601be7f10c
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/20230628/b35f502f/attachment-0001.html>
More information about the ghc-commits
mailing list