Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: 5880fb11 by Simon Peyton Jones at 2025-08-08T17:05:39+01:00 Wibbles solver Iterate the simples more often than plugins - - - - - b9dbfd95 by Simon Peyton Jones at 2025-08-08T17:06:00+01:00 Improve pretty printer for HsExpr Given a very deeply-nested application, it just kept printing deeper and deeper. This small change makes it cut off. - - - - - 3 changed files: - compiler/GHC/Hs/Expr.hs - compiler/GHC/Tc/Solver/Solve.hs - compiler/GHC/Types/Basic.hs Changes: ===================================== compiler/GHC/Hs/Expr.hs ===================================== @@ -862,11 +862,9 @@ ppr_expr (HsOverLabel s l) = case ghcPass @p of ppr_expr (HsLit _ lit) = ppr lit ppr_expr (HsOverLit _ lit) = ppr lit ppr_expr (HsPar _ e) = parens (ppr_lexpr e) - -ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] - -ppr_expr e@(HsApp {}) = ppr_apps e [] -ppr_expr e@(HsAppType {}) = ppr_apps e [] +ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] +ppr_expr e@(HsApp {}) = pprApp e +ppr_expr e@(HsAppType {}) = pprApp e ppr_expr (OpApp _ e1 op e2) | Just pp_op <- ppr_infix_expr (unLoc op) @@ -1134,21 +1132,21 @@ ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e ppr_infix_hs_expansion _ = Nothing -ppr_apps :: (OutputableBndrId p) - => HsExpr (GhcPass p) - -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))] - -> SDoc -ppr_apps (HsApp _ (L _ fun) arg) args - = ppr_apps fun (Left arg : args) -ppr_apps (HsAppType _ (L _ fun) arg) args - = ppr_apps fun (Right arg : args) -ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args)) +pprApp :: (OutputableBndrId p) => HsExpr (GhcPass p) -> SDoc +pprApp app + = go app [] -- Collect arguments and print all at once where - pp (Left arg) = ppr arg - -- pp (Right (LHsWcTypeX (HsWC { hswc_body = L _ arg }))) - -- = char '@' <> pprHsType arg - pp (Right arg) - = text "@" <> ppr arg + go fun args + = case fun of + HsApp _ (L _ fun') arg -> go fun' (Left arg : args) + HsAppType _ (L _ fun') arg -> go fun' (Right arg : args) + _ -> ppr_app fun args + + ppr_app fun args = hang (ppr_expr fun) + 2 (pprDeeper (fsep (map pp args))) + + pp (Left arg) = ppr arg + pp (Right arg) = text "@" <> ppr arg pprDebugParendExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc ===================================== compiler/GHC/Tc/Solver/Solve.hs ===================================== @@ -42,7 +42,7 @@ import GHC.Types.Id( idType ) import GHC.Types.Var( EvVar, tyVarKind ) import GHC.Types.Var.Env import GHC.Types.Var.Set -import GHC.Types.Basic ( IntWithInf, intGtLimit ) +import GHC.Types.Basic ( IntWithInf, mulWithInf, intGtLimit ) import GHC.Types.Unique.Set( nonDetStrictFoldUniqSet ) import GHC.Data.Bag @@ -1043,49 +1043,55 @@ solveSimpleGivens givens solveSimpleWanteds :: Cts -> TcS Cts -- The result is not necessarily zonked -solveSimpleWanteds simples +solveSimpleWanteds wc = do { mode <- getTcSMode ; dflags <- getDynFlags ; inerts <- getInertSet + ; let iteration_count_flag = solverIterations dflags ; traceTcS "solveSimpleWanteds {" $ vcat [ text "Mode:" <+> ppr mode , text "Inerts:" <+> ppr inerts - , text "Wanteds to solve:" <+> ppr simples ] + , text "Wanteds to solve:" <+> ppr wc ] - ; (n,wc) <- go 1 (solverIterations dflags) simples + ; wc1 <- iterateToFixpoint iteration_count_flag + (do_solve_and_plugins iteration_count_flag) wc ; traceTcS "solveSimpleWanteds end }" $ - vcat [ text "iterations =" <+> ppr n - , text "residual =" <+> ppr wc ] - ; return wc } + vcat [ text "residual =" <+> ppr wc1 ] + ; return wc1 } where - go :: Int -> IntWithInf -> Cts -> TcS (Int, Cts) - -- See Note [The solveSimpleWanteds loop] - go n limit wc + do_solve_and_plugins :: IntWithInf -> Cts -> TcS (Bool,Cts) + do_solve_and_plugins icf wc + = do { wc1 <- iterateToFixpoint (icf `mulWithInf` 10) + do_solve wc + ; runTcPluginsWanted wc1 } + + do_solve :: Cts -> TcS (Bool,Cts) + -- Try this repeatedly, until no unifications happen + -- This is potentially quadratic, because we might solve just one + -- constraint in each iteration but that seems inevitable + do_solve wc = reportUnifications (solve_simple_wanteds wc) + + +iterateToFixpoint :: IntWithInf -> (Cts -> TcS (Bool,Cts)) -> Cts -> TcS Cts +-- See Note [The solveSimpleWanteds loop] +iterateToFixpoint limit do_it wc_orig + = go 1 wc_orig + where + go n wc | isEmptyBag wc - = return (n,wc) + = return wc | n `intGtLimit` limit = failTcS $ TcRnSimplifierTooManyIterations - simples limit (emptyWC { wc_simple = wc }) - | otherwise - = do { -- Solve - traceUnificationFlag "solveSimpleWanteds1" - ; (unif_happened, wc1) <- reportUnifications $ - solve_simple_wanteds wc - ; traceUnificationFlag "solveSimpleWanteds2" - - -- Run plugins - -- NB: runTcPluginsWanted has a fast path for empty wc1, - -- which is the common case - ; (rerun_plugin, wc2) <- runTcPluginsWanted wc1 - - ; if unif_happened || rerun_plugin - then do { traceTcS "solveSimple going round again:" empty - ; go (n+1) limit wc2 } -- Loop - else return (n, wc2) } -- Done + wc_orig limit (emptyWC { wc_simple = wc }) + | otherwise + = do { (something_happened, wc1) <- do_it wc + ; if something_happened + then go (n+1) wc1 + else return wc1 } solve_simple_wanteds :: Cts -> TcS Cts -- Try solving these constraints ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -109,7 +109,8 @@ module GHC.Types.Basic ( SuccessFlag(..), succeeded, failed, successIf, - IntWithInf, infinity, treatZeroAsInf, subWithInf, mkIntWithInf, intGtLimit, + IntWithInf, infinity, treatZeroAsInf, mkIntWithInf, + intGtLimit, subWithInf, mulWithInf, TypeOrKind(..), isTypeLevel, isKindLevel, @@ -2114,8 +2115,8 @@ instance Outputable IntWithInf where ppr (Int n) = int n instance Num IntWithInf where - (+) = plusWithInf - (*) = mulWithInf + (+) = plusWithInf2 + (*) = mulWithInf2 abs Infinity = Infinity abs (Int n) = Int (abs n) @@ -2132,16 +2133,21 @@ intGtLimit _ Infinity = False intGtLimit n (Int m) = n > m -- | Add two 'IntWithInf's -plusWithInf :: IntWithInf -> IntWithInf -> IntWithInf -plusWithInf Infinity _ = Infinity -plusWithInf _ Infinity = Infinity -plusWithInf (Int a) (Int b) = Int (a + b) +plusWithInf2 :: IntWithInf -> IntWithInf -> IntWithInf +plusWithInf2 Infinity _ = Infinity +plusWithInf2 _ Infinity = Infinity +plusWithInf2 (Int a) (Int b) = Int (a + b) -- | Multiply two 'IntWithInf's -mulWithInf :: IntWithInf -> IntWithInf -> IntWithInf -mulWithInf Infinity _ = Infinity -mulWithInf _ Infinity = Infinity -mulWithInf (Int a) (Int b) = Int (a * b) +mulWithInf2 :: IntWithInf -> IntWithInf -> IntWithInf +mulWithInf2 Infinity _ = Infinity +mulWithInf2 _ Infinity = Infinity +mulWithInf2 (Int a) (Int b) = Int (a * b) + +-- | Multiply an 'IntWithInfo` by an 'Int' +mulWithInf :: IntWithInf -> Int -> IntWithInf +mulWithInf Infinity _ = Infinity +mulWithInf (Int a) b = Int (a * b) -- | Subtract an 'Int' from an 'IntWithInf' subWithInf :: IntWithInf -> Int -> IntWithInf @@ -2461,4 +2467,4 @@ convImportLevel NotLevelled = NormalLevel convImportLevelSpec :: ImportDeclLevel -> ImportLevel convImportLevelSpec ImportDeclQuote = QuoteLevel -convImportLevelSpec ImportDeclSplice = SpliceLevel \ No newline at end of file +convImportLevelSpec ImportDeclSplice = SpliceLevel View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b5b238b121b19600e5c0a88d90ceae... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/0b5b238b121b19600e5c0a88d90ceae... You're receiving this email because of your account on gitlab.haskell.org.