Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 58d6142b by Simon Peyton Jones at 2025-08-14T12:15:10+01:00 More wibbles In particular, solve fundeps with Givens only - - - - - 5 changed files: - compiler/GHC/Runtime/Heap/Inspect.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Solver/InertSet.hs - compiler/GHC/Tc/Solver/Monad.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Runtime/Heap/Inspect.hs ===================================== @@ -253,7 +253,7 @@ pprTermM y p t = pprDeeper `liftM` ppr_termM y p t ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do tt_docs <- mapM (y app_prec) tt return $ cparen (not (null tt) && p >= app_prec) - (text dc_tag <+> pprDeeperList fsep tt_docs) + (text dc_tag <+> pprDeeper (fsep tt_docs)) ppr_termM y p Term{dc=Right dc, subTerms=tt} {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity @@ -270,7 +270,7 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt} show_tm tt_docs | null tt_docs = ppr dc | otherwise = cparen (p >= app_prec) $ - sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] + sep [ppr dc, nest 2 (pprDeeper (fsep tt_docs))] ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t ppr_termM y p RefWrap{wrapped_term=t} = do ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -929,6 +929,11 @@ solving. solveFunDeps :: CtEvidence -- The work item -> [FunDepEqn (CtLoc, RewriterSet)] -> TcS Bool +-- Solve a bunch of type-equality equations, generated by functional dependencies +-- By "solve" we mean: (only) do unifications. We do not generate evidence, and +-- other than unifications there should be no effects whatsoever +-- +-- Return True if some unifications happened -- See Note [FunDep and implicit parameter reactions] solveFunDeps work_ev fd_eqns | null fd_eqns ===================================== compiler/GHC/Tc/Solver/InertSet.hs ===================================== @@ -16,7 +16,7 @@ module GHC.Tc.Solver.InertSet ( -- * The inert set InertSet(..), InertCans(..), - emptyInertSet, emptyInertCans, + emptyInertSet, emptyInertCans, resetInertCans, noGivenNewtypeReprEqs, updGivenEqs, prohibitedSuperClassSolve, @@ -76,7 +76,7 @@ import GHC.Utils.Panic import GHC.Data.Bag import Control.Monad ( forM_ ) -import Data.List.NonEmpty ( NonEmpty(..), (<|) ) +import qualified Data.List.NonEmpty as NE import Data.Function ( on ) {- @@ -305,7 +305,7 @@ instance Outputable WorkList where * * ********************************************************************* -} -type CycleBreakerVarStack = NonEmpty (Bag (TcTyVar, TcType)) +type CycleBreakerVarStack = NE.NonEmpty (Bag (TcTyVar, TcType)) -- ^ a stack of (CycleBreakerTv, original family applications) lists -- first element in the stack corresponds to current implication; -- later elements correspond to outer implications @@ -323,6 +323,7 @@ data InertSet , inert_givens :: InertCans -- A subset of inert_cans, containing only Givens -- Used to initialise inert_cans when recursing inside implications + -- See `resetInertCans` , inert_cycle_breakers :: CycleBreakerVarStack @@ -378,13 +379,21 @@ emptyInertSet :: TcLevel -> InertSet emptyInertSet given_eq_lvl = IS { inert_cans = empty_cans , inert_givens = empty_cans - , inert_cycle_breakers = emptyBag :| [] + , inert_cycle_breakers = emptyBag NE.:| [] , inert_famapp_cache = emptyFunEqs , inert_solved_dicts = emptyDictMap , inert_safehask = emptyDictMap } where empty_cans = emptyInertCans given_eq_lvl + +resetInertCans :: InertSet -> InertSet +-- Reset the `inert_cans` to the saved `inert_givens :: InertCans` +-- In effect, this just purges all Wanteds from the InertSet +resetInertCans inerts@(IS { inert_givens = saved_givens }) + = inerts { inert_cans = saved_givens } + + {- Note [Solved dictionaries] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we apply a top-level instance declaration, we add the "solved" @@ -1913,8 +1922,9 @@ prohibitedSuperClassSolve given_loc wanted_loc -- | Push a fresh environment onto the cycle-breaker var stack. Useful -- when entering a nested implication. -pushCycleBreakerVarStack :: CycleBreakerVarStack -> CycleBreakerVarStack -pushCycleBreakerVarStack = (emptyBag <|) +pushCycleBreakerVarStack :: InertSet -> InertSet +pushCycleBreakerVarStack inerts@(IS { inert_cycle_breakers = cbs }) + = inerts { inert_cycle_breakers = emptyBag NE.<| cbs } -- | Add a new cycle-breaker binding to the top environment on the stack. addCycleBreakerBindings :: Bag (TcTyVar, Type) -- ^ (cbv,expansion) pairs @@ -1923,14 +1933,14 @@ addCycleBreakerBindings prs ics = assertPpr (all (isCycleBreakerTyVar . fst) prs) (ppr prs) $ ics { inert_cycle_breakers = add_to (inert_cycle_breakers ics) } where - add_to (top_env :| rest_envs) = (prs `unionBags` top_env) :| rest_envs + add_to (top_env NE.:| rest_envs) = (prs `unionBags` top_env) NE.:| rest_envs -- | Perform a monadic operation on all pairs in the top environment -- in the stack. forAllCycleBreakerBindings_ :: Monad m => CycleBreakerVarStack -> (TcTyVar -> TcType -> m ()) -> m () -forAllCycleBreakerBindings_ (top_env :| _rest_envs) action +forAllCycleBreakerBindings_ (top_env NE.:| _rest_envs) action = forM_ top_env (uncurry action) {-# INLINABLE forAllCycleBreakerBindings_ #-} -- to allow SPECIALISE later ===================================== compiler/GHC/Tc/Solver/Monad.hs ===================================== @@ -1177,14 +1177,13 @@ nestImplicTcS ev_binds_var inner_tclvl (TcS thing_inside) = TcS $ \ env@(TcSEnv { tcs_inerts = old_inert_var }) -> do { inerts <- TcM.readTcRef old_inert_var - -- Initialise the inert_cans from the inert_givens of the parent - -- so that the child is not polluted with the parent's inert Wanteds + -- resetInertcans: initialise the inert_cans from the inert_givens of the + -- parent so that the child is not polluted with the parent's inert Wanteds -- See Note [trySolveImplication] in GHC.Tc.Solver.Solve -- All other InertSet fields are inherited - ; let nest_inert = inerts { inert_cycle_breakers = pushCycleBreakerVarStack - (inert_cycle_breakers inerts) - , inert_cans = (inert_givens inerts) - { inert_given_eqs = False } } + ; let nest_inert = pushCycleBreakerVarStack $ + resetInertCans $ + inerts ; new_inert_var <- TcM.newTcRef nest_inert ; new_wl_var <- TcM.newTcRef emptyWorkList ; let nest_env = env { tcs_ev_binds = ev_binds_var @@ -1203,6 +1202,26 @@ nestImplicTcS ev_binds_var inner_tclvl (TcS thing_inside) #endif ; return res } +nestFunDepsTcS :: TcS a -> TcS (Bool, a) +nestFunDepsTcS (TcS thing_inside) + = reportUnifications $ + TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> + TcM.pushTcLevelM_ $ + -- pushTcLevelTcM: increase the level so that unification variables + -- allocated by the fundep-creation itself don't count as useful unifications + do { inerts <- TcM.readTcRef inerts_var + ; let nest_inerts = resetInertCans inerts + -- resetInertCasns: like nestImplicTcS + ; new_inert_var <- TcM.newTcRef nest_inerts + ; new_wl_var <- TcM.newTcRef emptyWorkList + ; let nest_env = env { tcs_inerts = new_inert_var + , tcs_worklist = new_wl_var } + + ; TcM.traceTc "nestFunDepsTcS {" empty + ; res <- thing_inside nest_env + ; TcM.traceTc "nestFunDepsTcS }" empty + ; return res } + nestTcS :: TcS a -> TcS a -- Use the current untouchables, augmenting the current -- evidence bindings, and solved dictionaries @@ -1262,24 +1281,6 @@ tryTcS (TcS thing_inside) ; return True } } -nestFunDepsTcS :: TcS a -> TcS (Bool, a) -nestFunDepsTcS (TcS thing_inside) - = reportUnifications $ - TcS $ \ env@(TcSEnv { tcs_inerts = inerts_var }) -> - TcM.pushTcLevelM_ $ - -- pushTcLevelTcM: increase the level so that unification variables - -- allocated by the fundep-creation itself don't count as useful unifications - do { inerts <- TcM.readTcRef inerts_var - ; new_inert_var <- TcM.newTcRef inerts - ; new_wl_var <- TcM.newTcRef emptyWorkList - ; let nest_env = env { tcs_inerts = new_inert_var - , tcs_worklist = new_wl_var } - - ; TcM.traceTc "nestFunDepsTcS {" empty - ; res <- thing_inside nest_env - ; TcM.traceTc "nestFunDepsTcS }" empty - ; return res } - updateInertsWith :: InertSet -> InertSet -> InertSet -- Update the current inert set with bits from a nested solve, -- that finished with a new inert set ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -528,8 +528,10 @@ pprDeeperList f ds | null ds = f [] | otherwise = SDoc work where - work ctx@SDC{ sdocStyle=PprUser {} } + work ctx@SDC{ sdocStyle=PprUser _ (PartWay {}) _ } = let -- Only do this depth-limitation in User style + -- when PartWay is on. Why not for DefaultDepth? + -- I have no idea; seems like a bug to me. go _ [] = [] go i (d:ds) | i >= default_depth = [text "...."] | otherwise = d : go (i+1) ds View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58d6142b4d86d4b6e157acdbf3cc685c... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/58d6142b4d86d4b6e157acdbf3cc685c... You're receiving this email because of your account on gitlab.haskell.org.