Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 02c7e59f by Simon Peyton Jones at 2025-08-10T22:51:15+01:00 Wibble HsExpr pretty printing - - - - - ccc04b9a by Simon Peyton Jones at 2025-08-10T22:51:29+01:00 Whitespace only - - - - - e8a76095 by Simon Peyton Jones at 2025-08-10T23:22:27+01:00 Small improvements - - - - - 4 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Solver/Equality.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Utils/Outputable.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -1144,6 +1144,7 @@ pprApp app ppr_app fun args = hang (ppr_expr fun) 2 (pprDeeper (fsep (map pp args))) + -- pprDeeper: go deeper as we step inside an argument pp (Left arg) = ppr arg pp (Right arg) = text "@" <> ppr arg ===================================== compiler/GHC/Tc/Solver/Equality.hs ===================================== @@ -35,7 +35,7 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep -- cleverly decomposes types, good for completeness checking import GHC.Core.Coercion import GHC.Core.Reduction -import GHC.Core.FamInstEnv ( FamInstEnvs ) +import GHC.Core.FamInstEnv ( FamInstEnvs ) import GHC.Core import GHC.Types.Var import GHC.Types.Var.Env ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -3,7 +3,6 @@ -- | Solving Class constraints CDictCan module GHC.Tc.Solver.FunDeps ( - unifyAndEmitFunDepWanteds, tryDictFunDeps, tryEqFunDeps ) where @@ -35,20 +34,16 @@ import GHC.Core.Coercion.Axiom import GHC.Builtin.Types.Literals( tryInteractTopFam, tryInteractInertFam ) import GHC.Types.Name -import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Misc( filterOut ) -import GHC.Data.Bag import GHC.Data.Pair import qualified Data.Semigroup as S -import Control.Monad - {- ********************************************************************* * * * Functional dependencies for dictionaries @@ -334,10 +329,14 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) do { inerts <- getInertCans ; traceTcS "tryDictFunDepsLocal {" (ppr dict_ct) - ; imp <- solveFunDeps $ - foldM do_interaction emptyCts $ - findDictsByClass (inert_dicts inerts) cls - ; traceTcS "tryDictFunDepsLocal }" (text "imp =" <+> ppr imp) + + ; let eqns :: [FunDepEqn (CtLoc, RewriterSet)] + eqns = foldr ((++) . do_interaction) [] $ + findDictsByClass (inert_dicts inerts) cls + ; imp <- solveFunDeps work_ev eqns + + ; traceTcS "tryDictFunDepsLocal }" $ + text "imp =" <+> ppr imp $$ text "eqns = " <+> ppr eqns ; if imp then startAgainWith (CDictCan dict_ct) else continueWith () } @@ -346,24 +345,17 @@ tryDictFunDepsLocal dict_ct@(DictCt { di_cls = cls, di_ev = work_ev }) work_loc = ctEvLoc work_ev work_is_given = isGiven work_ev - do_interaction :: Cts -> DictCt -> TcS Cts - do_interaction new_eqs1 (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted + do_interaction :: DictCt -> [FunDepEqn (CtLoc, RewriterSet)] + do_interaction (DictCt { di_ev = inert_ev }) -- This can be Given or Wanted | work_is_given && isGiven inert_ev -- Do not create FDs from Given/Given interactions -- See Note [No Given/Given fundeps] -- It is possible for work_ev to be Given when inert_ev is Wanted: -- this can happen if a Given is kicked out by a unification - = return new_eqs1 + = [] | otherwise - = do { new_eqs2 <- unifyFunDepWanteds_new work_ev $ - improveFromAnother (deriv_loc, inert_rewriters) - inert_pred work_pred - - ; traceTcS "tryDictFunDepsLocal item" $ - vcat [ ppr work_ev, ppr new_eqs2 ] - - ; return (new_eqs1 `unionBags` new_eqs2) } + = improveFromAnother (deriv_loc, inert_rewriters) inert_pred work_pred where inert_pred = ctEvPred inert_ev inert_loc = ctEvLoc inert_ev @@ -387,8 +379,7 @@ tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) ; traceTcS "tryDictFunDepsTop {" (ppr dict_ct) ; let eqns :: [FunDepEqn (CtLoc, RewriterSet)] eqns = improveFromInstEnv inst_envs mk_ct_loc cls xis - ; imp <- solveFunDeps $ - unifyFunDepWanteds_new ev eqns + ; imp <- solveFunDeps ev eqns ; traceTcS "tryDictFunDepsTop }" (text "imp =" <+> ppr imp) ; if imp then startAgainWith (CDictCan dict_ct) @@ -409,13 +400,6 @@ tryDictFunDepsTop dict_ct@(DictCt { di_ev = ev, di_cls = cls, di_tys = xis }) new_orig = FunDepOrigin2 dict_pred dict_origin inst_pred inst_loc -solveFunDeps :: TcS Cts -> TcS Bool -solveFunDeps generate_eqs - = do { (unif_happened, _res) <- nestFunDepsTcS $ - do { eqs <- generate_eqs - ; solveSimpleWanteds eqs } - ; return unif_happened } - {- Note [No Given/Given fundeps] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We do not create constraints from: @@ -799,7 +783,7 @@ improveWantedLocalFunEqs funeqs_for_tc fam_tc args work_ev rhs = do { traceTcS "interactFunEq improvements: " $ vcat [ text "Eqns:" <+> ppr improvement_eqns , text "Candidates:" <+> ppr funeqs_for_tc ] - ; unifyAndEmitFunDepWanteds work_ev improvement_eqns } + ; solveFunDeps work_ev improvement_eqns } where work_loc = ctEvLoc work_ev work_pred = ctEvPred work_ev @@ -945,54 +929,21 @@ solving. ************************************************************************ -} -unifyAndEmitFunDepWanteds :: CtEvidence -- The work item - -> [FunDepEqn (CtLoc, RewriterSet)] - -> TcS Bool -- True <=> some unification happened -unifyAndEmitFunDepWanteds ev fd_eqns +solveFunDeps :: CtEvidence -- The work item + -> [FunDepEqn (CtLoc, RewriterSet)] + -> TcS Bool +-- See Note [FunDep and implicit parameter reactions] +solveFunDeps work_ev fd_eqns | null fd_eqns - = return False + = return False -- common case noop + | otherwise - = do { (fresh_tvs_s, new_eqs, unified_tvs) <- wrapUnifierX ev Nominal do_fundeps - - -- Figure out if a "real" unification happened: See Note [unifyFunDeps] - ; let unif_happened = any is_old_tv unified_tvs - fresh_tvs = mkVarSet (concat fresh_tvs_s) - is_old_tv tv = not (tv `elemVarSet` fresh_tvs) - - ; -- Emit the deferred constraints - -- See Note [Work-list ordering] in GHC.Tc.Solved.Equality - -- - -- All the constraints in `cts` share the same rewriter set so, - -- rather than looking at it one by one, we pass it to - -- extendWorkListChildEqs; just a small optimisation. - ; unless (isEmptyBag new_eqs) $ - updWorkListTcS (extendWorkListChildEqs ev new_eqs) + = do { (unif_happened, _res) + <- nestFunDepsTcS $ + do { (_, eqs) <- unifyForAllBody work_ev Nominal do_fundeps + ; solveSimpleWanteds eqs } ; return unif_happened } - where - do_fundeps :: UnifyEnv -> TcM [[TcTyVar]] - do_fundeps env = mapM (do_one env) fd_eqns - - do_one :: UnifyEnv -> FunDepEqn (CtLoc, RewriterSet) -> TcM [TcTyVar] - do_one uenv (FDEqn { fd_qtvs = tvs, fd_eqs = eqs, fd_loc = (loc, rewriters) }) - = do { (fresh_tvs, eqs') <- instantiateFunDepEqn tvs (reverse eqs) - -- (reverse eqs): See Note [Reverse order of fundep equations] - ; uPairsTcM env_one eqs' - ; return fresh_tvs } - where - env_one = uenv { u_rewriters = u_rewriters uenv S.<> rewriters - , u_loc = loc } - -unifyFunDepWanteds_new :: CtEvidence -- The work item - -> [FunDepEqn (CtLoc, RewriterSet)] - -> TcS Cts --- See Note [FunDep and implicit parameter reactions] -unifyFunDepWanteds_new _ [] - = return emptyCts -- common case noop - -unifyFunDepWanteds_new ev fd_eqns - = do { (_, cts) <- unifyForAllBody ev Nominal do_fundeps - ; return cts } where do_fundeps :: UnifyEnv -> TcM () do_fundeps env = mapM_ (do_one env) fd_eqns ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -522,23 +522,21 @@ pprDeeper d = SDoc $ \ctx -> case sdocStyle ctx of _ -> runSDoc d ctx --- | Truncate a list that is longer than the current depth. +-- | Truncate a list that is longer than the default depth pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc pprDeeperList f ds | null ds = f [] | otherwise = SDoc work where - work ctx@SDC{sdocStyle=PprUser q depth c} - | DefaultDepth <- depth - = work (ctx { sdocStyle = PprUser q (PartWay (sdocDefaultDepth ctx)) c }) - | PartWay 0 <- depth - = Pretty.text "..." - | PartWay n <- depth + work ctx = let go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - in runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1)) c} + go i (d:ds) | i >= default_depth = [text "...."] + | otherwise = d : go (i+1) ds + in runSDoc (f (go 0 ds)) ctx + where + default_depth = sdocDefaultDepth ctx + work other_ctx = runSDoc (f ds) other_ctx pprSetDepth :: Depth -> SDoc -> SDoc View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0240183357637242886b779215b04ff... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0240183357637242886b779215b04ff... You're receiving this email because of your account on gitlab.haskell.org.