- ghc-commits - Haskell.org

[Git][ghc/ghc] Pushed new branch wip/supersven/test-master-full-ci
by Sven Tennie (＠supersven) 26 Sep '25

26 Sep '25

Sven Tennie pushed new branch wip/supersven/test-master-full-ci at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/supersven/test-master-full-ci You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/bomb_out] exprSize: Accumulate size as we go to allow early bomb out.
by Andreas Klebinger (＠AndreasK) 26 Sep '25

26 Sep '25

Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC Commits: 3e795969 by Andreas Klebinger at 2025-09-26T13:13:31+02:00 exprSize: Accumulate size as we go to allow early bomb out. When dealing with branches in the AST we now accumulate expr size across branches, rather than computing both branches before adding them up. This way we can abort early when it's clear an expression is too large to be useful. This fixes an issue I observed in #26425 where we sometimes spent a significant amount of time computing unfolding sizes in deeply nested but branching rhss. Speedup is on the order of ~1%-4% depending on the program we are compiling. - - - - - 1 changed file: - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -567,43 +567,46 @@ sizeExpr :: UnfoldingOpts -- Forcing bOMB_OUT_SIZE early prevents repeated -- unboxing of the Int argument. sizeExpr opts !bOMB_OUT_SIZE top_args expr - = size_up expr + = size_up sizeZero expr where - size_up (Cast e _) = size_up e - size_up (Tick _ e) = size_up e - size_up (Type _) = sizeZero -- Types cost nothing - size_up (Coercion _) = sizeZero - size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isZeroBitId f = sizeZero - -- Make sure we get constructor discounts even - -- on nullary constructors - | otherwise = size_up_call f [] 0 - - size_up (App fun arg) - | isTyCoArg arg = size_up fun - | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) - - size_up (Lam b e) - | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) - | otherwise = size_up e - - size_up (Let (NonRec binder rhs) body) - = size_up_rhs (binder, rhs) `addSizeNSD` - size_up body `addSizeN` - size_up_alloc binder - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up_rhs) - (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) - pairs - - size_up (Case e _ _ alts) = case nonEmpty alts of - Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee + size_up :: ExprSize -> CoreExpr -> ExprSize + size_up (TooBig) !_ = TooBig + size_up (SizeIs !s _ _) _ + | s > bOMB_OUT_SIZE = TooBig + size_up s (Cast e _) = size_up s e + size_up s (Tick _ e) = size_up s e + size_up s (Type _) = s -- Types cost nothing + size_up s (Coercion _) = s + size_up s (Lit lit) = addSizeNSD (sizeN (litSize lit)) s + size_up s (Var f) | isZeroBitId f = s + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call s f [] 0 + + size_up s (App fun arg) + | isTyCoArg arg = size_up s fun + | otherwise = size_up_app (stripDiscounts $ size_up s arg) + fun [arg] (if isZeroBitExpr arg then 1 else 0) + + size_up s (Lam b e) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (addSizeN s 10) e) + | otherwise = size_up s e + + size_up s (Let (NonRec binder rhs) body) + = let rhs_s = size_up_let s (binder, rhs) + in size_up (stripDiscounts $ rhs_s) body + + + size_up s (Let (Rec pairs) body) + = size_up (stripDiscounts (foldr (flip size_up_let) s pairs)) + body + + size_up s (Case e _ _ alts) = case nonEmpty alts of + Nothing -> size_up s e -- case e of {} never returns, so take size of scrutinee Just alts | Just v <- is_top_arg e -> -- We are scrutinising an argument variable let - alt_sizes = NE.map size_up_alt alts + alt_sizes = NE.map (size_up_alt s) alts -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable @@ -625,21 +628,24 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr alts_size tot_size _ = tot_size in - alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty - (foldr1 maxSize alt_sizes) + s `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself - | otherwise -> size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts + | otherwise -> foldr (addAltSize . size_up_alt s) + (size_up s e `addSizeNSD` case_size) + alts where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e + is_top_arg (Tick _t e) = is_top_arg e is_top_arg _ = Nothing where + case_size | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) | otherwise = sizeZero @@ -675,48 +681,61 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr | otherwise = False - size_up_rhs (bndr, rhs) + size_up_let :: ExprSize -> (Id, CoreExpr) -> ExprSize + size_up_let s (bndr, rhs) | JoinPoint join_arity <- idJoinPointHood bndr -- Skip arguments to join point , (_bndrs, body) <- collectNBinders join_arity rhs - = size_up body + = size_up s body | otherwise - = size_up rhs + = size_up s rhs `addSizeN` size_up_alloc bndr ------------ -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args voids - | isTyCoArg arg = size_up_app fun args voids - | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) voids - size_up_app (Var fun) args voids = size_up_call fun args voids - size_up_app (Tick _ expr) args voids = size_up_app expr args voids - size_up_app (Cast expr _) args voids = size_up_app expr args voids - size_up_app other args voids = size_up other `addSizeN` - callSize (length args) voids + size_up_app :: ExprSize -> CoreExpr -> [CoreExpr] -> Int -> ExprSize + size_up_app s (App fun arg) args voids + | isTyCoArg arg = size_up_app s fun args voids + | isZeroBitExpr arg = size_up_app s fun (arg:args) (voids + 1) + | otherwise = let arg_size = stripDiscounts $ size_up s arg + in size_up_app arg_size fun (arg:args) voids + size_up_app s (Var fun) args voids = size_up_call s fun args voids + size_up_app s (Tick _ expr) args voids = size_up_app s expr args voids + size_up_app s (Cast expr _) args voids = size_up_app s expr args voids + size_up_app s other args voids = size_up (s `addSizeN` callSize (length args) voids) other + -- if the lhs is not an App or a Var, or an invisible thing like a -- Tick or Cast, then we should charge for a complete call plus the -- size of the lhs itself. ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId cls _ -> classOpSize opts cls top_args val_args - _ | fun `hasKey` buildIdKey -> buildSize - | fun `hasKey` augmentIdKey -> augmentSize - | otherwise -> funSize opts top_args fun (length val_args) voids + size_up_call :: ExprSize -> Id -> [CoreExpr] -> Int -> ExprSize + size_up_call !s fun val_args voids + = let !n_args = length val_args + call_size = case idDetails fun of + FCallId _ -> sizeN (callSize n_args voids) + DataConWorkId dc -> conSize dc n_args + PrimOpId op _ -> primOpSize op n_args + ClassOpId cls _ -> classOpSize opts cls top_args val_args + _ | fun `hasKey` buildIdKey -> buildSize + | fun `hasKey` augmentIdKey -> augmentSize + | otherwise -> funSize opts top_args fun n_args voids + in s `addSizeNSD` call_size ------------ - size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + -- size_up_alt returns on the alternatives size, not counting the accumulated + -- size passed in unless we reach TooBig. This is to facility better discount + -- calculation based on the size of only the alternative. + size_up_alt TooBig _ = TooBig + size_up_alt (SizeIs {_es_size_is=s}) (Alt _con _bndrs rhs) = + size_up (sizeN s) rhs + -- Why add and then subtract s? + -- If the expression large enough this will ensure we bomb out early. + `addSizeN` (10 -s) + -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- - -- IMPORTANT: *do* charge 1 for the alternative, else we + -- IMPORTANT: *do* charge 10 for the alternative, else we -- find that giant case nests are treated as practically free -- A good example is Foreign.C.Error.errnoToIOError @@ -753,6 +772,14 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr (xs `unionBags` ys) d2 -- Ignore d1 + -- Throw away the discount for scrutinizing the expression. + -- Used for things like `let x = rhs in body` where we only consider + -- this benefit for the body. + -- Why? `x` is visible to `body` either way, so it really should not + -- affect our inlining decision either way. + stripDiscounts TooBig = TooBig + stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0) + -- don't count expressions such as State# RealWorld -- exclude join points, because they can be rep-polymorphic -- and typePrimRep will crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e7959697150cef223cf3f206d0c907… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/3e7959697150cef223cf3f206d0c907… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/bomb_out] exprSize: Accumulate size as we go to allow early bomb out.
by Andreas Klebinger (＠AndreasK) 26 Sep '25

26 Sep '25

Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC Commits: 66c56b5f by Andreas Klebinger at 2025-09-26T13:12:52+02:00 exprSize: Accumulate size as we go to allow early bomb out. When dealing with branches in the AST we now accumulate expr size across branches, rather than computing both branches before adding them up. This way we can abort early when it's clear an expression is too large to be useful. This fixes an issue I observed in #26425 where we sometimes spent a significant amount of time computing unfolding sizes in deeply nested but branching rhss. Speedup is on the order of ~1%-4% depending on the program we are compiling. - - - - - 1 changed file: - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -566,44 +566,48 @@ sizeExpr :: UnfoldingOpts -- Forcing bOMB_OUT_SIZE early prevents repeated -- unboxing of the Int argument. +-- {-# NOINLINE sizeExpr #-} sizeExpr opts !bOMB_OUT_SIZE top_args expr - = size_up expr + = size_up sizeZero expr where - size_up (Cast e _) = size_up e - size_up (Tick _ e) = size_up e - size_up (Type _) = sizeZero -- Types cost nothing - size_up (Coercion _) = sizeZero - size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isZeroBitId f = sizeZero - -- Make sure we get constructor discounts even - -- on nullary constructors - | otherwise = size_up_call f [] 0 - - size_up (App fun arg) - | isTyCoArg arg = size_up fun - | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) - - size_up (Lam b e) - | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) - | otherwise = size_up e - - size_up (Let (NonRec binder rhs) body) - = size_up_rhs (binder, rhs) `addSizeNSD` - size_up body `addSizeN` - size_up_alloc binder - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up_rhs) - (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) - pairs - - size_up (Case e _ _ alts) = case nonEmpty alts of - Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee + size_up :: ExprSize -> CoreExpr -> ExprSize + size_up (TooBig) !_ = TooBig + size_up (SizeIs !s _ _) _ + | s > bOMB_OUT_SIZE = TooBig + size_up s (Cast e _) = size_up s e + size_up s (Tick _ e) = size_up s e + size_up s (Type _) = s -- Types cost nothing + size_up s (Coercion _) = s + size_up s (Lit lit) = addSizeNSD (sizeN (litSize lit)) s + size_up s (Var f) | isZeroBitId f = s + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call s f [] 0 + + size_up s (App fun arg) + | isTyCoArg arg = size_up s fun + | otherwise = size_up_app (stripDiscounts $ size_up s arg) + fun [arg] (if isZeroBitExpr arg then 1 else 0) + + size_up s (Lam b e) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (addSizeN s 10) e) + | otherwise = size_up s e + + size_up s (Let (NonRec binder rhs) body) + = let rhs_s = size_up_let s (binder, rhs) + in size_up (stripDiscounts $ rhs_s) body + + + size_up s (Let (Rec pairs) body) + = size_up (stripDiscounts (foldr (flip size_up_let) s pairs)) + body + + size_up s (Case e _ _ alts) = case nonEmpty alts of + Nothing -> size_up s e -- case e of {} never returns, so take size of scrutinee Just alts | Just v <- is_top_arg e -> -- We are scrutinising an argument variable let - alt_sizes = NE.map size_up_alt alts + alt_sizes = NE.map (size_up_alt s) alts -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable @@ -625,21 +629,24 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr alts_size tot_size _ = tot_size in - alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty - (foldr1 maxSize alt_sizes) + s `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself - | otherwise -> size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts + | otherwise -> foldr (addAltSize . size_up_alt s) + (size_up s e `addSizeNSD` case_size) + alts where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e + is_top_arg (Tick _t e) = is_top_arg e is_top_arg _ = Nothing where + case_size | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) | otherwise = sizeZero @@ -675,48 +682,61 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr | otherwise = False - size_up_rhs (bndr, rhs) + size_up_let :: ExprSize -> (Id, CoreExpr) -> ExprSize + size_up_let s (bndr, rhs) | JoinPoint join_arity <- idJoinPointHood bndr -- Skip arguments to join point , (_bndrs, body) <- collectNBinders join_arity rhs - = size_up body + = size_up s body | otherwise - = size_up rhs + = size_up s rhs `addSizeN` size_up_alloc bndr ------------ -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args voids - | isTyCoArg arg = size_up_app fun args voids - | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) voids - size_up_app (Var fun) args voids = size_up_call fun args voids - size_up_app (Tick _ expr) args voids = size_up_app expr args voids - size_up_app (Cast expr _) args voids = size_up_app expr args voids - size_up_app other args voids = size_up other `addSizeN` - callSize (length args) voids + size_up_app :: ExprSize -> CoreExpr -> [CoreExpr] -> Int -> ExprSize + size_up_app s (App fun arg) args voids + | isTyCoArg arg = size_up_app s fun args voids + | isZeroBitExpr arg = size_up_app s fun (arg:args) (voids + 1) + | otherwise = let arg_size = stripDiscounts $ size_up s arg + in size_up_app arg_size fun (arg:args) voids + size_up_app s (Var fun) args voids = size_up_call s fun args voids + size_up_app s (Tick _ expr) args voids = size_up_app s expr args voids + size_up_app s (Cast expr _) args voids = size_up_app s expr args voids + size_up_app s other args voids = size_up (s `addSizeN` callSize (length args) voids) other + -- if the lhs is not an App or a Var, or an invisible thing like a -- Tick or Cast, then we should charge for a complete call plus the -- size of the lhs itself. ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId cls _ -> classOpSize opts cls top_args val_args - _ | fun `hasKey` buildIdKey -> buildSize - | fun `hasKey` augmentIdKey -> augmentSize - | otherwise -> funSize opts top_args fun (length val_args) voids + size_up_call :: ExprSize -> Id -> [CoreExpr] -> Int -> ExprSize + size_up_call !s fun val_args voids + = let !n_args = length val_args + call_size = case idDetails fun of + FCallId _ -> sizeN (callSize n_args voids) + DataConWorkId dc -> conSize dc n_args + PrimOpId op _ -> primOpSize op n_args + ClassOpId cls _ -> classOpSize opts cls top_args val_args + _ | fun `hasKey` buildIdKey -> buildSize + | fun `hasKey` augmentIdKey -> augmentSize + | otherwise -> funSize opts top_args fun n_args voids + in s `addSizeNSD` call_size ------------ - size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + -- size_up_alt returns on the alternatives size, not counting the accumulated + -- size passed in unless we reach TooBig. This is to facility better discount + -- calculation based on the size of only the alternative. + size_up_alt TooBig _ = TooBig + size_up_alt (SizeIs {_es_size_is=s}) (Alt _con _bndrs rhs) = + size_up (sizeN s) rhs + -- Why add and then subtract s? + -- If the expression large enough this will ensure we bomb out early. + `addSizeN` (10 -s) + -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- - -- IMPORTANT: *do* charge 1 for the alternative, else we + -- IMPORTANT: *do* charge 10 for the alternative, else we -- find that giant case nests are treated as practically free -- A good example is Foreign.C.Error.errnoToIOError @@ -753,6 +773,14 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr (xs `unionBags` ys) d2 -- Ignore d1 + -- Throw away the discount for scrutinizing the expression. + -- Used for things like `let x = rhs in body` where we only consider + -- this benefit for the body. + -- Why? `x` is visible to `body` either way, so it really should not + -- affect our inlining decision either way. + stripDiscounts TooBig = TooBig + stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0) + -- don't count expressions such as State# RealWorld -- exclude join points, because they can be rep-polymorphic -- and typePrimRep will crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66c56b5fcd8bfb9eafce80f204ce093… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/66c56b5fcd8bfb9eafce80f204ce093… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/andreask/bomb_out] exprSize: Accumulate size as we go to allow early bomb out.
by Andreas Klebinger (＠AndreasK) 26 Sep '25

26 Sep '25

Andreas Klebinger pushed to branch wip/andreask/bomb_out at Glasgow Haskell Compiler / GHC Commits: 0b0df4b7 by Andreas Klebinger at 2025-09-26T13:06:54+02:00 exprSize: Accumulate size as we go to allow early bomb out. When dealing with branches in the AST we now accumulate expr size across branches, rather than computing both branches before adding them up. This way we can abort early when it's clear an expression is too large to be useful. This fixes an issue I observed in #26425 where we sometimes spent a significant amount of time computing unfolding sizes in deeply nested but branching rhss. Speedup is on the order of ~1%-4% depending on the program we are compiling. - - - - - 1 changed file: - compiler/GHC/Core/Unfold.hs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -335,6 +335,7 @@ isValFun (Lam b e) | isRuntimeVar b = True | otherwise = isValFun e isValFun _ = False +{-# NOINLINE calcUnfoldingGuidance #-} calcUnfoldingGuidance :: UnfoldingOpts -> Bool -- Definitely a top-level, bottoming binding @@ -566,44 +567,48 @@ sizeExpr :: UnfoldingOpts -- Forcing bOMB_OUT_SIZE early prevents repeated -- unboxing of the Int argument. +-- {-# NOINLINE sizeExpr #-} sizeExpr opts !bOMB_OUT_SIZE top_args expr - = size_up expr + = size_up sizeZero expr where - size_up (Cast e _) = size_up e - size_up (Tick _ e) = size_up e - size_up (Type _) = sizeZero -- Types cost nothing - size_up (Coercion _) = sizeZero - size_up (Lit lit) = sizeN (litSize lit) - size_up (Var f) | isZeroBitId f = sizeZero - -- Make sure we get constructor discounts even - -- on nullary constructors - | otherwise = size_up_call f [] 0 - - size_up (App fun arg) - | isTyCoArg arg = size_up fun - | otherwise = size_up arg `addSizeNSD` - size_up_app fun [arg] (if isZeroBitExpr arg then 1 else 0) - - size_up (Lam b e) - | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up e `addSizeN` 10) - | otherwise = size_up e - - size_up (Let (NonRec binder rhs) body) - = size_up_rhs (binder, rhs) `addSizeNSD` - size_up body `addSizeN` - size_up_alloc binder - - size_up (Let (Rec pairs) body) - = foldr (addSizeNSD . size_up_rhs) - (size_up body `addSizeN` sum (map (size_up_alloc . fst) pairs)) - pairs - - size_up (Case e _ _ alts) = case nonEmpty alts of - Nothing -> size_up e -- case e of {} never returns, so take size of scrutinee + size_up :: ExprSize -> CoreExpr -> ExprSize + size_up (TooBig) !_ = TooBig + size_up (SizeIs !s _ _) _ + | s > bOMB_OUT_SIZE = TooBig + size_up s (Cast e _) = size_up s e + size_up s (Tick _ e) = size_up s e + size_up s (Type _) = s -- Types cost nothing + size_up s (Coercion _) = s + size_up s (Lit lit) = addSizeNSD (sizeN (litSize lit)) s + size_up s (Var f) | isZeroBitId f = s + -- Make sure we get constructor discounts even + -- on nullary constructors + | otherwise = size_up_call s f [] 0 + + size_up s (App fun arg) + | isTyCoArg arg = size_up s fun + | otherwise = size_up_app (stripDiscounts $ size_up s arg) + fun [arg] (if isZeroBitExpr arg then 1 else 0) + + size_up s (Lam b e) + | isId b && not (isZeroBitId b) = lamScrutDiscount opts (size_up (addSizeN s 10) e) + | otherwise = size_up s e + + size_up s (Let (NonRec binder rhs) body) + = let rhs_s = size_up_let s (binder, rhs) + in size_up (stripDiscounts $ rhs_s) body + + + size_up s (Let (Rec pairs) body) + = size_up (stripDiscounts (foldr (flip size_up_let) s pairs)) + body + + size_up s (Case e _ _ alts) = case nonEmpty alts of + Nothing -> size_up s e -- case e of {} never returns, so take size of scrutinee Just alts | Just v <- is_top_arg e -> -- We are scrutinising an argument variable let - alt_sizes = NE.map size_up_alt alts + alt_sizes = NE.map (size_up_alt s) alts -- alts_size tries to compute a good discount for -- the case when we are scrutinising an argument variable @@ -625,21 +630,24 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr alts_size tot_size _ = tot_size in - alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty - (foldr1 maxSize alt_sizes) + s `addSizeNSD` alts_size (foldr1 addAltSize alt_sizes) -- alts is non-empty + (foldr1 maxSize alt_sizes) -- Good to inline if an arg is scrutinised, because -- that may eliminate allocation in the caller -- And it eliminates the case itself - | otherwise -> size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) case_size alts + | otherwise -> foldr (addAltSize . size_up_alt s) + (size_up s e `addSizeNSD` case_size) + alts where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e + is_top_arg (Tick _t e) = is_top_arg e is_top_arg _ = Nothing where + case_size | is_inline_scrut e, lengthAtMost alts 1 = sizeN (-10) | otherwise = sizeZero @@ -675,48 +683,61 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr | otherwise = False - size_up_rhs (bndr, rhs) + size_up_let :: ExprSize -> (Id, CoreExpr) -> ExprSize + size_up_let s (bndr, rhs) | JoinPoint join_arity <- idJoinPointHood bndr -- Skip arguments to join point , (_bndrs, body) <- collectNBinders join_arity rhs - = size_up body + = size_up s body | otherwise - = size_up rhs + = size_up s rhs `addSizeN` size_up_alloc bndr ------------ -- size_up_app is used when there's ONE OR MORE value args - size_up_app (App fun arg) args voids - | isTyCoArg arg = size_up_app fun args voids - | isZeroBitExpr arg = size_up_app fun (arg:args) (voids + 1) - | otherwise = size_up arg `addSizeNSD` - size_up_app fun (arg:args) voids - size_up_app (Var fun) args voids = size_up_call fun args voids - size_up_app (Tick _ expr) args voids = size_up_app expr args voids - size_up_app (Cast expr _) args voids = size_up_app expr args voids - size_up_app other args voids = size_up other `addSizeN` - callSize (length args) voids + size_up_app :: ExprSize -> CoreExpr -> [CoreExpr] -> Int -> ExprSize + size_up_app s (App fun arg) args voids + | isTyCoArg arg = size_up_app s fun args voids + | isZeroBitExpr arg = size_up_app s fun (arg:args) (voids + 1) + | otherwise = let arg_size = stripDiscounts $ size_up s arg + in size_up_app arg_size fun (arg:args) voids + size_up_app s (Var fun) args voids = size_up_call s fun args voids + size_up_app s (Tick _ expr) args voids = size_up_app s expr args voids + size_up_app s (Cast expr _) args voids = size_up_app s expr args voids + size_up_app s other args voids = size_up (s `addSizeN` callSize (length args) voids) other + -- if the lhs is not an App or a Var, or an invisible thing like a -- Tick or Cast, then we should charge for a complete call plus the -- size of the lhs itself. ------------ - size_up_call :: Id -> [CoreExpr] -> Int -> ExprSize - size_up_call fun val_args voids - = case idDetails fun of - FCallId _ -> sizeN (callSize (length val_args) voids) - DataConWorkId dc -> conSize dc (length val_args) - PrimOpId op _ -> primOpSize op (length val_args) - ClassOpId cls _ -> classOpSize opts cls top_args val_args - _ | fun `hasKey` buildIdKey -> buildSize - | fun `hasKey` augmentIdKey -> augmentSize - | otherwise -> funSize opts top_args fun (length val_args) voids + size_up_call :: ExprSize -> Id -> [CoreExpr] -> Int -> ExprSize + size_up_call !s fun val_args voids + = let !n_args = length val_args + call_size = case idDetails fun of + FCallId _ -> sizeN (callSize n_args voids) + DataConWorkId dc -> conSize dc n_args + PrimOpId op _ -> primOpSize op n_args + ClassOpId cls _ -> classOpSize opts cls top_args val_args + _ | fun `hasKey` buildIdKey -> buildSize + | fun `hasKey` augmentIdKey -> augmentSize + | otherwise -> funSize opts top_args fun n_args voids + in s `addSizeNSD` call_size ------------ - size_up_alt (Alt _con _bndrs rhs) = size_up rhs `addSizeN` 10 + -- size_up_alt returns on the alternatives size, not counting the accumulated + -- size passed in unless we reach TooBig. This is to facility better discount + -- calculation based on the size of only the alternative. + size_up_alt TooBig _ = TooBig + size_up_alt (SizeIs {_es_size_is=s}) (Alt _con _bndrs rhs) = + size_up (sizeN s) rhs + -- Why add and then subtract s? + -- If the expression large enough this will ensure we bomb out early. + `addSizeN` (10 -s) + -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- - -- IMPORTANT: *do* charge 1 for the alternative, else we + -- IMPORTANT: *do* charge 10 for the alternative, else we -- find that giant case nests are treated as practically free -- A good example is Foreign.C.Error.errnoToIOError @@ -753,6 +774,14 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr (xs `unionBags` ys) d2 -- Ignore d1 + -- Throw away the discount for scrutinizing the expression. + -- Used for things like `let x = rhs in body` where we only consider + -- this benefit for the body. + -- Why? `x` is visible to `body` either way, so it really should not + -- affect our inlining decision either way. + stripDiscounts TooBig = TooBig + stripDiscounts (SizeIs n xs _) = (SizeIs n xs 0) + -- don't count expressions such as State# RealWorld -- exclude join points, because they can be rep-polymorphic -- and typePrimRep will crash View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0b0df4b70c297b296a8dbe711e3baa3… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0b0df4b70c297b296a8dbe711e3baa3… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-spj] Accept error message changes
by Simon Peyton Jones (＠simonpj) 26 Sep '25

26 Sep '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: e61cec2a by Simon Peyton Jones at 2025-09-26T10:32:06+01:00 Accept error message changes Plus compile time improvement Metrics: compile_time/bytes allocated Baseline Test value New value Change ---------------------- -------------------------------------- T5030(normal) 173,839,232 148,115,248 -14.8% GOOD hard_hole_fits(normal) 286,768,048 284,015,416 -1.0% geo. mean -0.2% minimum -14.8% maximum +0.3% Metric Decrease: T5030 - - - - - 17 changed files: - compiler/GHC/Tc/Errors.hs - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Solver/FunDeps.hs - compiler/GHC/Tc/Types/Constraint.hs - compiler/GHC/Tc/Types/Origin.hs - compiler/GHC/Tc/Utils/TcMType.hs - testsuite/tests/default/default-fail05.stderr - testsuite/tests/indexed-types/should_fail/T1897b.stderr - testsuite/tests/indexed-types/should_fail/T9662.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr - testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr - testsuite/tests/partial-sigs/should_fail/T14040a.stderr - testsuite/tests/rep-poly/RepPolyRightSection.stderr - testsuite/tests/typecheck/no_skolem_info/T14040.stderr - − testsuite/tests/typecheck/should_compile/T13651.stderr - testsuite/tests/typecheck/should_compile/all.T - testsuite/tests/typecheck/should_fail/T8603.stderr Changes: ===================================== compiler/GHC/Tc/Errors.hs ===================================== @@ -778,8 +778,8 @@ Which errors are suppressed? Historical (SCE2). Fundep constraints never "escape" into the main solver and so never show up in error messages. - See Note [Functional dependencies in type inference] inb GHC.Tc.Solver.FunDeps. - So this wrinkle is now just a historical note. + See (SOLVE-FD) in Note [Overview of functional dependencies in type inference] + in GHC.Tc.Solver.FunDeps. So this wrinkle is now just a historical note. Errors which arise from the interaction of two Wanted fun-dep constraints. Example: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -929,7 +929,7 @@ newFlexiTyVarQL :: QLFlag -> OccName -> MetaInfo -> TcKind -> TcM TcTyVar newFlexiTyVarQL do_ql occ info kind = do { lvl <- getTcLevelQL do_ql ; ref <- newMutVar Flexi - ; name <- newSysName occ -- See Note [Name of an unification variable] + ; name <- newSysName occ -- See Note [Name of a unification variable] -- in GHC.Tc.Utils.TcMType ; let details = MetaTv { mtv_info = info , mtv_ref = ref ===================================== compiler/GHC/Tc/Solver/FunDeps.hs ===================================== @@ -41,33 +41,33 @@ import GHC.Data.Pair import Data.Maybe( mapMaybe ) -{- Note [Functional dependencies in type inference] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +{- Note [Overview of functional dependencies in type inference] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is our plan for dealing with functional dependencies * When we have failed to solve a Wanted constraint, do this - 1. Generate any fundep-equalities [FunDepEqns] from that constraint. - 2. Try to solve that [FunDepEqns] - 3. If any unifications happened, send the constraint back to the - start of the pipeline - -* Step (1) How we generate those [FunDepEqns] varies: + - (GEN-FD) Generate any fundep-equalities [FunDepEqns] from that constraint. + - (SOLVE-FD) Try to solve that [FunDepEqns] + - (KICK-FD) If any unifications happened, + * kick out any inert constraints that mention the unified variables + * send the current constraint back to the start of the pipeline; + might now be soluble, and it probably isn't inert + +* (GEN-FD) How we generate those [FunDepEqns] varies: - tryDictFunDeps: for class constraints (C t1 .. tn) we look at top-level instances and inert Givens - tryEqFunDeps: for type-family equalities (F t1 .. tn ~ ty) we look at top-level family instances and inert Given family equalities -* Step (2). We use `solveFunDeps` to solve the [FunDepEqns] in a nested +* (SOLVE-FD) We use `solveFunDeps` to solve the [FunDepEqns] in a nested solver. Key property: The ONLY effect of `solveFunDeps` is possibly to perform unifications: - - It entirely discards any unsolved fundep equalities. - - It entirely discards any evidence arising from solving fundep equalities -* Step (3) if we did any unifications in Step (2), we start again with the +* (KICK-FD) if we did any unifications in (SOLVE-FD), we start again with the current unsolved Wanted. It might now be soluble! * For Given constraints, things are different: @@ -518,7 +518,8 @@ mkTopUserFamEqFDs fam_tc inj_flags work_args work_rhs in_scope = mkInScopeSet (tyCoVarsOfType work_rhs) trim_qtvs :: Subst -> [TcTyVar] -> (Subst,[TcTyVar]) - -- Tricky stuff: see (TF1) in Note [Fundeps and top-level family instances] + -- Tricky stuff: see (TIF1) in + -- Note [Type inference for type families with injectivity] trim_qtvs subst [] = (subst, []) trim_qtvs subst (tv:tvs) | tv `elemSubst` subst = trim_qtvs subst tvs @@ -765,7 +766,7 @@ solveFunDeps :: CtEvidence -- The work item -- -- The returned Bool is True if some unifications happened -- --- See Note [Overview of fundeps] +-- See (SOLVE-FD) in Note [Overview of functional dependencies in type inference] solveFunDeps work_ev fd_eqns | null fd_eqns = return False -- Common case no-op ===================================== compiler/GHC/Tc/Types/Constraint.hs ===================================== @@ -1330,7 +1330,7 @@ can't be solved. But not quite all such constraints; see wrinkles. (IW4) Historical note: we used to have equalities arising from Wanted/Wanted fundep interactions, which we did not want to treat as insoluble. But now such fundep constraints never escape. - See Note [Functional dependencies in type inference] + See Note [Overview of functional dependencies in type inference] Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ ===================================== compiler/GHC/Tc/Types/Origin.hs ===================================== @@ -598,9 +598,10 @@ data CtOrigin | ArrowCmdOrigin -- Arising from an arrow command | AnnOrigin -- An annotation - | FunDepOrigin -- A functional dependency. We don't need auxiliary info - -- because fundep constraints never show up in errors - -- See Note [Functional dependencies in type inference] + | FunDepOrigin -- A functional dependency. + -- We don't need auxiliary info because fundep constraints + -- never show up in errors. See (SOLVE-FD) in + -- Note [Overview of functional dependencies in type inference] | InjTFOrigin1 -- injective type family equation combining PredType CtOrigin RealSrcSpan -- This constraint arising from ... ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -716,14 +716,14 @@ Proposal 29). Note [Name of a unification variable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We give unification variables a /System/ Name, which is eagerly elmininated -the the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and -GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) - -Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. +We give unification variables a /System/ Name, which is treated specially +in two ways + +* It is eagerly elmininated the the unifier; see + GHC.Tc.Utils.Unify.nicer_to_update_tv1, and + GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) + +* It influences the way it is tidied; see TypeRep.tidyTyVarBndr. -} newMetaTyVarName :: FastString -> TcM Name @@ -732,7 +732,7 @@ newMetaTyVarName str = newSysName (mkTyVarOccFS str) cloneMetaTyVarName :: Name -> TcM Name --- See Note [Name of an instantiated type variable] +-- Makes a /System/ Name; see Note [Name of a unification variable] cloneMetaTyVarName name = newSysName (nameOccName name) ===================================== testsuite/tests/default/default-fail05.stderr ===================================== @@ -1,7 +1,7 @@ default-fail05.hs:11:10: error: [GHC-39999] - • Ambiguous type variable ‘t0’ arising from a use of ‘toList’ - prevents the constraint ‘(Foldable t0)’ from being solved. - Probable fix: use a type annotation to specify what ‘t0’ should be. + • Ambiguous type variable ‘f0’ arising from a use of ‘toList’ + prevents the constraint ‘(Foldable f0)’ from being solved. + Probable fix: use a type annotation to specify what ‘f0’ should be. Potentially matching instances: instance Foldable (Either a) -- Defined in ‘GHC.Internal.Data.Foldable’ @@ -14,9 +14,9 @@ default-fail05.hs:11:10: error: [GHC-39999] In a stmt of a 'do' block: print (toList $ pure 21) default-fail05.hs:11:19: error: [GHC-39999] - • Ambiguous type variable ‘t0’ arising from a use of ‘pure’ - prevents the constraint ‘(Applicative t0)’ from being solved. - Probable fix: use a type annotation to specify what ‘t0’ should be. + • Ambiguous type variable ‘f0’ arising from a use of ‘pure’ + prevents the constraint ‘(Applicative f0)’ from being solved. + Probable fix: use a type annotation to specify what ‘f0’ should be. Potentially matching instances: instance Applicative IO -- Defined in ‘GHC.Internal.Base’ instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’ @@ -28,11 +28,11 @@ default-fail05.hs:11:19: error: [GHC-39999] In a stmt of a 'do' block: print (toList $ pure 21) default-fail05.hs:12:3: error: [GHC-39999] - • Ambiguous type variable ‘t1’ arising from a use of ‘traverse’ - prevents the constraint ‘(Traversable t1)’ from being solved. + • Ambiguous type variable ‘t0’ arising from a use of ‘traverse’ + prevents the constraint ‘(Traversable t0)’ from being solved. Relevant bindings include - main :: IO (t1 ()) (bound at default-fail05.hs:10:1) - Probable fix: use a type annotation to specify what ‘t1’ should be. + main :: IO (t0 ()) (bound at default-fail05.hs:10:1) + Probable fix: use a type annotation to specify what ‘t0’ should be. Potentially matching instances: instance Traversable (Either a) -- Defined in ‘GHC.Internal.Data.Traversable’ @@ -51,11 +51,11 @@ default-fail05.hs:12:3: error: [GHC-39999] traverse print (pure 42) default-fail05.hs:12:19: error: [GHC-39999] - • Ambiguous type variable ‘t1’ arising from a use of ‘pure’ - prevents the constraint ‘(Applicative t1)’ from being solved. + • Ambiguous type variable ‘t0’ arising from a use of ‘pure’ + prevents the constraint ‘(Applicative t0)’ from being solved. Relevant bindings include - main :: IO (t1 ()) (bound at default-fail05.hs:10:1) - Probable fix: use a type annotation to specify what ‘t1’ should be. + main :: IO (t0 ()) (bound at default-fail05.hs:10:1) + Probable fix: use a type annotation to specify what ‘t0’ should be. Potentially matching instances: instance Applicative IO -- Defined in ‘GHC.Internal.Base’ instance Applicative Maybe -- Defined in ‘GHC.Internal.Base’ ===================================== testsuite/tests/indexed-types/should_fail/T1897b.stderr ===================================== @@ -1,14 +1,14 @@ T1897b.hs:16:1: error: [GHC-83865] - • Couldn't match type: Depend a0 - with: Depend a - Expected: t (Depend a) -> Bool - Actual: t (Depend a0) -> Bool + • Couldn't match type: Depend b0 + with: Depend b + Expected: t (Depend b) -> Bool + Actual: t (Depend b0) -> Bool Note: ‘Depend’ is a non-injective type family. - The type variable ‘a0’ is ambiguous + The type variable ‘b0’ is ambiguous • In the ambiguity check for the inferred type for ‘isValid’ To defer the ambiguity check to use sites, enable AllowAmbiguousTypes When checking the inferred type - isValid :: forall {t :: * -> *} {a}. - (Foldable t, Bug a) => - t (Depend a) -> Bool + isValid :: forall {t :: * -> *} {b}. + (Foldable t, Bug b) => + t (Depend b) -> Bool ===================================== testsuite/tests/indexed-types/should_fail/T9662.stderr ===================================== @@ -1,12 +1,12 @@ T9662.hs:49:8: error: [GHC-25897] - • Couldn't match type ‘k’ with ‘Int’ + • Couldn't match type ‘n’ with ‘Int’ Expected: Exp (((sh :. k) :. m) :. n) -> Exp (((sh :. m) :. n) :. k) Actual: Exp (Tuple (((Atom a0 :. Atom Int) :. Atom Int) :. Atom Int)) -> Exp (Plain (((Unlifted (Atom a0) :. Exp Int) :. Exp Int) :. Exp Int)) - ‘k’ is a rigid type variable bound by + ‘n’ is a rigid type variable bound by the type signature for: test :: forall sh k m n. Shape (((sh :. k) :. m) :. n) -> Shape (((sh :. m) :. n) :. k) ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail10.stderr ===================================== @@ -1,10 +1,9 @@ -RecordDotSyntaxFail10.hs:40:11: error: [GHC-18872] - • Couldn't match type ‘Int’ with ‘[Char]’ +RecordDotSyntaxFail10.hs:40:11: error: [GHC-39999] + • No instance for ‘HasField "quux" Quux String’ • In the second argument of ‘($)’, namely ‘a {foo.bar.baz.quux}’ In a stmt of a 'do' block: print $ a {foo.bar.baz.quux} In the expression: do let a = Foo {foo = ...} - do let a = ... let quux = "Expecto patronum!" print $ a {foo.bar.baz.quux} ===================================== testsuite/tests/parser/should_fail/RecordDotSyntaxFail13.stderr ===================================== @@ -1,13 +1,10 @@ -RecordDotSyntaxFail13.hs:26:11: error: [GHC-18872] - • Couldn't match type ‘Int’ with ‘Foo -> Int’ - arising from a functional dependency between: - constraint ‘HasField "foo" Foo (Foo -> Int)’ - arising from a record update - instance ‘HasField "foo" Foo Int’ - at RecordDotSyntaxFail13.hs:21:10-31 +RecordDotSyntaxFail13.hs:26:11: error: [GHC-39999] + • No instance for ‘HasField "foo" Foo (Foo -> Int)’ + arising from a record update + (maybe you haven't applied a function to enough arguments?) • In the second argument of ‘($)’, namely ‘a {foo}’ In a stmt of a 'do' block: print $ a {foo} In the expression: - do let a = ... + do let a = Foo {foo = 12} print $ a {foo} ===================================== testsuite/tests/partial-sigs/should_fail/T14040a.stderr ===================================== @@ -1,6 +1,6 @@ T14040a.hs:26:46: error: [GHC-46956] - • Couldn't match kind ‘k1’ with ‘WeirdList z’ - Expected kind ‘WeirdList k1’, + • Couldn't match kind ‘k0’ with ‘WeirdList z’ + Expected kind ‘WeirdList k0’, but ‘xs’ has kind ‘WeirdList (WeirdList z)’ because kind variable ‘z’ would escape its scope This (rigid, skolem) kind variable is bound by @@ -24,8 +24,8 @@ T14040a.hs:26:46: error: [GHC-46956] -> p _ wl T14040a.hs:27:27: error: [GHC-46956] - • Couldn't match kind ‘k0’ with ‘z’ - Expected kind ‘WeirdList k0’, + • Couldn't match kind ‘k1’ with ‘z’ + Expected kind ‘WeirdList k1’, but ‘WeirdCons x xs’ has kind ‘WeirdList z’ because kind variable ‘z’ would escape its scope This (rigid, skolem) kind variable is bound by ===================================== testsuite/tests/rep-poly/RepPolyRightSection.stderr ===================================== @@ -8,6 +8,7 @@ RepPolyRightSection.hs:14:11: error: [GHC-55287] • * Cannot unify ‘r’ with the type variable ‘q0’ because the former is not a concrete ‘RuntimeRep’. - • In the expression: `g` undefined + • In the expression: g + In the expression: `g` undefined In an equation for ‘test2’: test2 = (`g` undefined) ===================================== testsuite/tests/typecheck/no_skolem_info/T14040.stderr ===================================== @@ -1,6 +1,6 @@ T14040.hs:27:46: error: [GHC-46956] - • Couldn't match kind ‘k1’ with ‘WeirdList z’ - Expected kind ‘WeirdList k1’, + • Couldn't match kind ‘k0’ with ‘WeirdList z’ + Expected kind ‘WeirdList k0’, but ‘xs’ has kind ‘WeirdList (WeirdList z)’ because kind variable ‘z’ would escape its scope This (rigid, skolem) kind variable is bound by @@ -24,8 +24,8 @@ T14040.hs:27:46: error: [GHC-46956] -> p _ wl T14040.hs:28:27: error: [GHC-46956] - • Couldn't match kind ‘k0’ with ‘z’ - Expected kind ‘WeirdList k0’, + • Couldn't match kind ‘k1’ with ‘z’ + Expected kind ‘WeirdList k1’, but ‘WeirdCons x xs’ has kind ‘WeirdList z’ because kind variable ‘z’ would escape its scope This (rigid, skolem) kind variable is bound by ===================================== testsuite/tests/typecheck/should_compile/T13651.stderr deleted ===================================== @@ -1,22 +0,0 @@ - -T13651.hs:12:8: error: [GHC-25897] - • Could not deduce ‘cr ~ Bar h (Foo r)’ - from the context: (F cr cu ~ Bar h (Bar r u), - F cu cs ~ Bar (Foo h) (Bar u s)) - bound by the type signature for: - foo :: forall cr cu h r u cs s. - (F cr cu ~ Bar h (Bar r u), F cu cs ~ Bar (Foo h) (Bar u s)) => - Bar h (Bar r u) -> Bar (Foo h) (Bar u s) -> Foo (cr -> cs) - at T13651.hs:(12,8)-(14,65) - ‘cr’ is a rigid type variable bound by - the type signature for: - foo :: forall cr cu h r u cs s. - (F cr cu ~ Bar h (Bar r u), F cu cs ~ Bar (Foo h) (Bar u s)) => - Bar h (Bar r u) -> Bar (Foo h) (Bar u s) -> Foo (cr -> cs) - at T13651.hs:(12,8)-(14,65) - • In the ambiguity check for ‘foo’ - To defer the ambiguity check to use sites, enable AllowAmbiguousTypes - In the type signature: - foo :: (F cr cu ~ Bar h (Bar r u), - F cu cs ~ Bar (Foo h) (Bar u s)) => - Bar h (Bar r u) -> Bar (Foo h) (Bar u s) -> Foo (cr -> cs) ===================================== testsuite/tests/typecheck/should_compile/all.T ===================================== @@ -586,7 +586,7 @@ test('T13594', normal, compile_fail, ['']) test('T13603', normal, compile, ['']) test('T13333', normal, compile, ['']) test('T13585', [extra_files(['T13585.hs', 'T13585a.hs', 'T13585b.hs'])], makefile_test, []) -test('T13651', normal, compile_fail, ['']) +test('T13651', normal, compile, ['']) test('T13651a', normal, compile, ['']) test('T13680', normal, compile, ['']) test('T13785', normal, compile, ['']) ===================================== testsuite/tests/typecheck/should_fail/T8603.stderr ===================================== @@ -3,8 +3,8 @@ T8603.hs:33:17: error: [GHC-18872] When matching types m0 :: * -> * [a2] :: * - Expected: [a2] -> StateT s RV a0 - Actual: t0 m0 (StateT s RV a0) + Expected: [a2] -> StateT s RV a1 + Actual: t0 m0 (StateT s RV a1) • The function ‘lift’ is applied to two visible arguments, but its type ‘(Control.Monad.Trans.Class.MonadTrans t, Monad m) => m a -> t m a’ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e61cec2ab4aed4b049d29121d8f7dbd… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e61cec2ab4aed4b049d29121d8f7dbd… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 6 commits: Document etymology of "bind" as the name for `>>=`
by Marge Bot (＠marge-bot) 26 Sep '25

26 Sep '25

Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: b418408b by Irene Knapp at 2025-09-25T09:47:54-04:00 Document etymology of "bind" as the name for `>>=` It took me twenty years of contemplation to realize why it's called that. I therefore feel that it may not be obvious to beginners. - - - - - e9c5e46f by Brandon Chinn at 2025-09-25T09:48:36-04:00 Fix tabs in string gaps (#26415) Tabs in string gaps were broken in bb030d0d because previously, string gaps were manually parsed, but now it's lexed by the usual Alex grammar and post-processed after successful lexing. It broke because of a discrepancy between GHC's lexer grammar and the Haskell Report. The Haskell Report includes tabs in whitechar: whitechar → newline | vertab | space | tab | uniWhite $whitechar used to include tabs until 18 years ago, when it was removed in order to exclude tabs from $white_no_nl in order to warn on tabs: 6e202120. In this MR, I'm adding \t back into $whitechar, and explicitly excluding \t from the $white_no_nl+ rule ignoring all whitespace in source code, which more accurately colocates the "ignore all whitespace except tabs, which is handled in the next line" logic. As a side effect of this MR, tabs are now allowed in pragmas; currently, a pragma written as {-# \t LANGUAGE ... #-} is interpreted as the tab character being the pragma name, and GHC warns "Unrecognized pragma". With this change, tabs are ignored as whitespace, which more closely matches the Report anyway. - - - - - 8bf5b309 by Cheng Shao at 2025-09-25T09:49:18-04:00 wasm: remove the --no-turbo-fast-api-calls hack from dynamic linker shebang This patch removes the `--no-turbo-fast-api-calls` hack from the dyld script shebang; it was used to workaround v8 fast call coredumps in nodejs and no longer needed, and comes with a performance penalty, hence the removal. - - - - - 35622b41 by Sylvain Henry at 2025-09-26T05:25:33-04:00 Revert "Add necessary flag for js linking" This reverts commit 84f68e2231b2eddb2e1dc4e90af394ef0f2e803f. This commit didn't have the expected effect. See discussion in #26290. Instead we export HEAP8 and HEAPU8 from rts/js/mem.js - - - - - 179265cd by Sylvain Henry at 2025-09-26T05:25:33-04:00 JS: export HEAPU8 (#26290) This is now required by newer Emscripten versions. - - - - - ad319868 by Andreas Klebinger at 2025-09-26T05:25:34-04:00 sizeExpr: Improve Tick handling. When determining if we scrutinize a function argument we now properly look through ticks. Fixes #26444. - - - - - 12 changed files: - compiler/GHC/Core/Unfold.hs - compiler/GHC/Parser/Lexer.x - compiler/GHC/Parser/Lexer/String.x - libraries/ghc-internal/src/GHC/Internal/Base.hs - m4/fptools_set_c_ld_flags.m4 - rts/js/mem.js - testsuite/driver/testlib.py - + testsuite/tests/parser/should_run/T26415.hs - + testsuite/tests/parser/should_run/T26415.stdout - testsuite/tests/parser/should_run/all.T - utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs - utils/jsffi/dyld.mjs Changes: ===================================== compiler/GHC/Core/Unfold.hs ===================================== @@ -637,6 +637,7 @@ sizeExpr opts !bOMB_OUT_SIZE top_args expr where is_top_arg (Var v) | v `elem` top_args = Just v is_top_arg (Cast e _) = is_top_arg e + is_top_arg (Tick _t e) = is_top_arg e is_top_arg _ = Nothing where ===================================== compiler/GHC/Parser/Lexer.x ===================================== @@ -145,7 +145,7 @@ import GHC.Parser.String $unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl = [\n\r\f] $space = [\ $unispace] -$whitechar = [$nl \v $space] +$whitechar = [$nl \t \v $space] $white_no_nl = $whitechar # \n -- TODO #8424 $tab = \t @@ -248,7 +248,7 @@ haskell :- -- Alex "Rules" -- everywhere: skip whitespace -$white_no_nl+ ; +($white_no_nl # \t)+ ; $tab { warnTab } -- Everywhere: deal with nested comments. We explicitly rule out ===================================== compiler/GHC/Parser/Lexer/String.x ===================================== @@ -25,7 +25,7 @@ import GHC.Utils.Panic (panic) $unispace = \x05 -- Trick Alex into handling Unicode. See Note [Unicode in Alex]. $nl = [\n\r\f] $space = [\ $unispace] -$whitechar = [$nl \v $space] +$whitechar = [$nl \t \v $space] $tab = \t $ascdigit = 0-9 ===================================== libraries/ghc-internal/src/GHC/Internal/Base.hs ===================================== @@ -1353,9 +1353,9 @@ class Applicative m => Monad m where -- bs a -- @ -- - -- An alternative name for this function is \'bind\', but some people - -- may refer to it as \'flatMap\', which results from it being equivalent - -- to + -- An alternative name for this function is \'bind\', because it + -- is used to introduce bindings in monadic contexts, but some people may + -- refer to it as \'flatMap\', which results from it being equivalent to -- -- @\\x f -> 'join' ('fmap' f x) :: Monad m => m a -> (a -> m b) -> m b@ -- ===================================== m4/fptools_set_c_ld_flags.m4 ===================================== @@ -109,9 +109,6 @@ AC_DEFUN([FPTOOLS_SET_C_LD_FLAGS], $2="$$2 -mcmodel=medium" ;; - javascript*) - $3="$$3 -sEXPORTED_RUNTIME_METHODS=HEAP8,HEAPU8" - esac AC_MSG_RESULT([done]) ===================================== rts/js/mem.js ===================================== @@ -1,5 +1,5 @@ //#OPTIONS:CPP -//#OPTIONS:EMCC:EXPORTED_RUNTIME_METHODS=addFunction,removeFunction,getEmptyTableSlot,HEAP8 +//#OPTIONS:EMCC:EXPORTED_RUNTIME_METHODS=addFunction,removeFunction,getEmptyTableSlot,HEAP8,HEAPU8 // #define GHCJS_TRACE_META 1 ===================================== testsuite/driver/testlib.py ===================================== @@ -3005,7 +3005,7 @@ def normalise_errmsg(s: str) -> str: # Emscripten displays cache info and old emcc doesn't support EMCC_LOGGING=0 s = re.sub('cache:INFO: .*\n', '', s) # Old emcc warns when we export HEAP8 but new one requires it (see #26290) - s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') + s = s.replace('warning: invalid item in EXPORTED_RUNTIME_METHODS: HEAP8\nwarning: invalid item in EXPORTED_RUNTIME_METHODS: HEAPU8\nemcc: warning: warnings in JS library compilation [-Wjs-compiler]\n','') return s ===================================== testsuite/tests/parser/should_run/T26415.hs ===================================== @@ -0,0 +1,7 @@ +{-# LANGUAGE MultilineStrings #-} + +main :: IO () +main = do + -- The below strings contain the characters ['\\', '\t', '\\'] + print "\ \" + print """\ \""" ===================================== testsuite/tests/parser/should_run/T26415.stdout ===================================== @@ -0,0 +1,2 @@ +"" +"" ===================================== testsuite/tests/parser/should_run/all.T ===================================== @@ -27,6 +27,7 @@ test('RecordDotSyntax4', [extra_files(['RecordDotSyntaxA.hs'])], multimod_compil test('RecordDotSyntax5', normal, compile_and_run, ['']) test('ListTuplePunsConstraints', extra_files(['ListTuplePunsConstraints.hs']), ghci_script, ['ListTuplePunsConstraints.script']) test('T25937', normal, compile_and_run, ['']) +test('T26415', normal, compile_and_run, ['']) # Multiline strings test('MultilineStrings', normal, compile_and_run, ['']) ===================================== utils/ghc-toolchain/src/GHC/Toolchain/Tools/Link.hs ===================================== @@ -324,10 +324,6 @@ addPlatformDepLinkFlags archOs cc ccLink0 = do ArchOS ArchPPC OSAIX -> -- We need `-D_THREAD_SAFE` to unlock the thread-local `errno`. return $ ccLink2 & over _prgFlags (++["-D_THREAD_SAFE","-Wl,-bnotextro"]) - ArchOS ArchJavaScript OSGhcjs -> - -- Since https://github.com/emscripten-core/emscripten/blob/main/ChangeLog.md#407---… - -- the emcc linker does not export the HEAP8 memory view which is used by the js RTS by default anymore. - return $ ccLink2 & _prgFlags %++ "-sEXPORTED_RUNTIME_METHODS=HEAP8,HEAPU8" _ -> return ccLink2 ===================================== utils/jsffi/dyld.mjs ===================================== @@ -1,4 +1,4 @@ -#!/usr/bin/env -S node --disable-warning=ExperimentalWarning --max-old-space-size=65536 --no-turbo-fast-api-calls --wasm-lazy-validation +#!/usr/bin/env -S node --disable-warning=ExperimentalWarning --max-old-space-size=65536 --wasm-lazy-validation // Note [The Wasm Dynamic Linker] // ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/893a94deae6551baac3b4b3e964046… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/893a94deae6551baac3b4b3e964046… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/fix-ghc-boot-host] hadrian: fix GHC.Platform.Host generation for cross stage1
by Cheng Shao (＠TerrorJack) 26 Sep '25

26 Sep '25

Cheng Shao pushed to branch wip/fix-ghc-boot-host at Glasgow Haskell Compiler / GHC Commits: 0af75d62 by Cheng Shao at 2025-09-26T04:24:00+02:00 hadrian: fix GHC.Platform.Host generation for cross stage1 This patch fixes incorrectly GHC.Platform.Host generation logic for cross stage1 in hadrian (#26449). Also adds T26449 test case to witness the fix. Co-authored-by: Codex <codex(a)openai.com> - - - - - 3 changed files: - hadrian/src/Rules/Generate.hs - + testsuite/tests/cross/should_run/T26449.hs - + testsuite/tests/cross/should_run/all.T Changes: ===================================== hadrian/src/Rules/Generate.hs ===================================== @@ -606,8 +606,12 @@ generateVersionHs = do generatePlatformHostHs :: Expr String generatePlatformHostHs = do trackGenerateHs - cHostPlatformArch <- queryHost (archOS_arch . tgtArchOs) - cHostPlatformOS <- queryHost (archOS_OS . tgtArchOs) + stage <- getStage + let chooseHostQuery = case stage of + Stage0 {} -> queryHost + _ -> queryTarget + cHostPlatformArch <- chooseHostQuery (archOS_arch . tgtArchOs) + cHostPlatformOS <- chooseHostQuery (archOS_OS . tgtArchOs) return $ unlines [ "module GHC.Platform.Host where" , "" ===================================== testsuite/tests/cross/should_run/T26449.hs ===================================== @@ -0,0 +1,16 @@ +import Control.Monad +import GHC.Platform.ArchOS +import GHC.Platform.Host +import System.Info + +main :: IO () +main = + when ((arch, os) /= (arch', os')) $ + fail $ + "System.Info says host platform is " + <> show (arch, os) + <> " but GHC.Platform.Host says " + <> show (arch', os') + where + (arch', os') = + (stringEncodeArch hostPlatformArch, stringEncodeOS hostPlatformOS) ===================================== testsuite/tests/cross/should_run/all.T ===================================== @@ -0,0 +1 @@ +test('T26449', [], compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0af75d62897b2f1934cf5f8a87d5454… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/0af75d62897b2f1934cf5f8a87d5454… You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/fix-ghc-boot-host
by Cheng Shao (＠TerrorJack) 26 Sep '25

26 Sep '25

Cheng Shao pushed new branch wip/fix-ghc-boot-host at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/fix-ghc-boot-host You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc] Pushed new branch wip/wasm-internal-interpreter
by Cheng Shao (＠TerrorJack) 26 Sep '25

26 Sep '25

Cheng Shao pushed new branch wip/wasm-internal-interpreter at Glasgow Haskell Compiler / GHC -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/tree/wip/wasm-internal-interpreter You're receiving this email because of your account on gitlab.haskell.org.

1 0

[Git][ghc/ghc][wip/T23162-spj] Now it compiles
by Simon Peyton Jones (＠simonpj) 25 Sep '25

25 Sep '25

Simon Peyton Jones pushed to branch wip/T23162-spj at Glasgow Haskell Compiler / GHC Commits: e62e731a by Simon Peyton Jones at 2025-09-26T00:05:16+01:00 Now it compiles - - - - - 3 changed files: - compiler/GHC/Tc/Gen/App.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/Tc/Utils/TcMType.hs Changes: ===================================== compiler/GHC/Tc/Gen/App.hs ===================================== @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RecursiveDo #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] @@ -47,7 +48,7 @@ import GHC.Core.TyCo.Subst ( substTyWithInScope ) import GHC.Core.Type import GHC.Core.Coercion -import GHC.Builtin.Types ( multiplicityTy ) +import GHC.Builtin.Types ( multiplicityTy, runtimeRepTy ) import GHC.Builtin.PrimOps( tagToEnumKey ) import GHC.Builtin.Names @@ -59,6 +60,7 @@ import GHC.Types.SrcLoc import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet ) import GHC.Data.Maybe +import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Outputable as Outputable @@ -395,9 +397,7 @@ tcApp rn_expr exp_res_ty -- Step 3: Instantiate the function type (taking a quick look at args) ; do_ql <- wantQuickLook rn_fun ; (inst_args, app_res_rho) - <- setQLInstLevel do_ql $ -- See (TCAPP1) and (TCAPP2) in - -- Note [tcApp: typechecking applications] - tcInstFun do_ql inst_final tc_head fun_sigma rn_args + <- tcInstFun do_ql inst_final tc_head fun_sigma rn_args ; case do_ql of NoQL -> do { traceTc "tcApp:NoQL" (ppr rn_fun $$ ppr app_res_rho) @@ -431,10 +431,6 @@ tcApp rn_expr exp_res_ty -- Step 5.5: wrap up ; finishApp tc_head tc_args app_res_rho res_wrap } } -setQLInstLevel :: QLFlag -> TcM a -> TcM a -setQLInstLevel DoQL thing_inside = setTcLevel QLInstVar thing_inside -setQLInstLevel NoQL thing_inside = thing_inside - quickLookResultType :: TcRhoType -> ExpRhoType -> TcM () -- This function implements the shaded bit of rule APP-Downarrow in -- Fig 5 of the QL paper: "A quick look at impredicativity" (ICFP'20). @@ -723,7 +719,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args -- addHeadCtxt: important for the class constraints -- that may be emitted from instantiating fun_sigma addHeadCtxt fun_ctxt $ - instantiateSigma fun_orig fun_conc_tvs tvs theta body2 + instantiateSigma do_ql fun_orig fun_conc_tvs tvs theta body2 -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. -- NB: we are doing this even when "acc" is not empty, @@ -786,8 +782,7 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args -- not defer in any way, because this is a QL instantiation variable. -- It's easier just to do the job directly here. do { arg_tys <- zipWithM new_arg_ty (leadingValArgs args) [pos..] - ; rr_ty <- newFlexiTyVarTyQL do_ql runtimeRepTy - ; res_ty <- newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty) + ; res_ty <- newOpenFlexiTyVarTyQL do_ql TauTv ; let fun_ty' = mkScaledFunTys arg_tys res_ty -- Fill in kappa := nu_1 -> .. -> nu_n -> res_nu @@ -827,12 +822,12 @@ tcInstFun do_ql inst_final (tc_fun, fun_ctxt) fun_sigma rn_args new_arg_ty :: LHsExpr GhcRn -> Int -> TcM (Scaled TcType) -- Make a fresh nus for each argument in rule IVAR new_arg_ty (L _ arg) i - = do { arg_nu <- newOpenFlexiFRRTyVarTy $ + = do { arg_nu <- newArgTyVarTyQL do_ql $ FRRExpectedFunTy (ExpectedFunTyArg (HsExprTcThing tc_fun) arg) i -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc], -- thereby ensuring that the arguments have concrete runtime representations - ; mult_ty <- newFlexiTyVarTyQL do_ql multiplicityTy + ; mult_ty <- newFlexiTyVarTyQL do_ql (mkTyVarOccFS (fsLit "m")) TauTv multiplicityTy -- mult_ty: e need variables for argument multiplicities (#18731) -- Otherwise, 'undefined x' wouldn't be linear in x @@ -916,30 +911,55 @@ addArgCtxt ctxt (L arg_loc arg) thing_inside {- ********************************************************************* * * Instantiating fresh type variables + + Functions in here use getTcLevelQL to decide what level + to put on fresh unification variables. If do_ql = DoQL, we + ignore the level in the monad, and use QLInstVar instead, + thereby giving birth to a Quick Look instantiation varaible * * ********************************************************************* -} -getTcLevelQL :: DoQL -> TcM TcLevel +getTcLevelQL :: QLFlag -> TcM TcLevel +-- If Quick Look is on, instantiate all fresh unification variables +-- at level QLInstVar; they are instantiation variables getTcLevelQL DoQL = return QLInstVar getTcLevelQL NoQL = getTcLevel -newFlexiTyVarTyQL :: DoQL -> TcKind -> TcM TcType -newFlexiTyVarTyQL do_ql kind - = do { lvl <- getTcLevelQL do_ql - ; newMetaTyVarTyAtLevel lvl kind } - -{- -newArgTyVarQL do_ql frr_ctxt - = do { th_lvl <- getThLevel - ; rr_ty <- case th_lvl of - TypedBrack {} -> newFlexiTyVarTyQL do_ql runtimeRepTy - _ -> mdo { - ; rr_ty <- - ; newFlexiTyVarTyQL do_ql (mkTYPEapp rr_ty) } --} - -instantiateSigma :: CtOrigin - -> QLFlag +newFlexiTyVarQL :: QLFlag -> OccName -> MetaInfo -> TcKind -> TcM TcTyVar +newFlexiTyVarQL do_ql occ info kind + = do { lvl <- getTcLevelQL do_ql + ; ref <- newMutVar Flexi + ; name <- newSysName occ -- See Note [Name of an unification variable] + -- in GHC.Tc.Utils.TcMType + ; let details = MetaTv { mtv_info = info + , mtv_ref = ref + , mtv_tclvl = lvl } + ; return (mkTcTyVar name kind details) } + +newFlexiTyVarTyQL :: QLFlag -> OccName -> MetaInfo -> TcKind -> TcM TcType +newFlexiTyVarTyQL do_ql occ info kind + = mkTyVarTy <$> newFlexiTyVarQL do_ql occ info kind + +newOpenFlexiTyVarTyQL :: QLFlag -> MetaInfo -> TcM TcType +newOpenFlexiTyVarTyQL do_ql rr_info + = do { let rr_occ = mkTyVarOccFS (fsLit "cx") + tv_occ = mkTyVarOccFS (fsLit "q") + ; rr_ty <- newFlexiTyVarTyQL do_ql rr_occ rr_info runtimeRepTy + ; arg_nu <- newFlexiTyVarTyQL do_ql tv_occ TauTv (mkTYPEapp rr_ty) + ; return arg_nu } + +newArgTyVarTyQL :: QLFlag -> FixedRuntimeRepContext -> TcM TcType +newArgTyVarTyQL do_ql frr_ctxt + = mdo { let conc_orig = ConcreteFRR $ + FixedRuntimeRepOrigin + { frr_context = frr_ctxt + , frr_type = arg_nu } + ; rr_info <- mkConcreteInfo conc_orig + ; arg_nu <- newOpenFlexiTyVarTyQL do_ql rr_info + ; return arg_nu } + +instantiateSigma :: QLFlag + -> CtOrigin -> ConcreteTyVars -- ^ concreteness information -> [TyVar] -> TcThetaType -> TcSigmaType @@ -947,9 +967,8 @@ instantiateSigma :: CtOrigin -- (instantiate orig tvs theta ty) -- instantiates the type variables tvs, emits the (instantiated) -- constraints theta, and returns the (instantiated) type ty -instantiateSigma orig do_ql concs tvs theta body_ty - = do { tv_lvl <- getTcLevelQL do_ql - ; rec (subst, inst_tvs) <- mapAccumLM (new_meta tv_lvl subst) empty_subst tvs +instantiateSigma do_ql orig concs tvs theta body_ty + = do { rec (subst, inst_tvs) <- mapAccumLM (new_meta subst) empty_subst tvs ; let inst_theta = substTheta subst theta inst_body = substTy subst body_ty @@ -959,7 +978,7 @@ instantiateSigma orig do_ql concs tvs theta body_ty , text "tvs" <+> ppr tvs , text "theta" <+> ppr theta , text "type" <+> debugPprType body_ty - , text "with" <+> vcat (map debugPprType inst_tv_tys) + , text "with" <+> ppr inst_tvs , text "theta:" <+> ppr inst_theta ]) ; return (wrap, inst_body) } @@ -969,35 +988,26 @@ instantiateSigma orig do_ql concs tvs theta body_ty -- We just want an accurate free-var set empty_subst = mkEmptySubst in_scope - new_meta :: TcLevel -> Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) - new_meta tv_lvl final_subst subst tv - = do { name <- cloneMetaTyVarName (tyVarName tv) - ; ref <- newMutVar Flexi - ; info <- get_info tv - ; let details = MetaTv { mtv_info = info - , mtv_ref = ref - , mtv_tclvl = tv_lvl } - ; let substd_kind = substTy subst (tyVarKind tv) - new_tv = mkTcTyVar name substd_kind details - new_subst = extendTvSubstWithClone subst tv new_tv + new_meta :: Subst -> Subst -> TyVar -> TcM (Subst, TcTyVar) + new_meta final_subst subst tv + = do { let occ = getOccName tv + substd_kind = substTy subst (tyVarKind tv) + ; info <- get_info final_subst tv + ; new_tv <- newFlexiTyVarQL do_ql occ info substd_kind + ; let new_subst = extendTvSubstWithClone subst tv new_tv ; return (new_subst, new_tv) } get_info :: Subst -> TyVar -> TcM MetaInfo - get_info concs final_subst tv + get_info final_subst tv -- Is this a type variable that must be instantiated to a concrete type? -- If so, create a ConcreteTv metavariable instead of a plain TauTv. -- See Note [Representation-polymorphism checking built-ins] -- in GHC.Tc.Utils.Concrete. - -- - -- But check TH level: see [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. + | Just conc_orig0 <- lookupNameEnv concs (tyVarName tv) , let conc_orig = substConcreteTvOrigin final_subst body_ty conc_orig0 -- See Note [substConcreteTvOrigin]. - = do { th_lvl <- getThLevel - ; case th_lvl of - TypedBrack {} -> return TauTv - _ -> return (ConcreteTv conc) } + = mkConcreteInfo conc_orig -- The vastly common case | otherwise ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -80,7 +80,6 @@ import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Var.Env import GHC.Types.Id import GHC.Types.Name -import GHC.Types.Name.Env import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.Var import qualified GHC.LanguageExtensions as LangExt @@ -304,7 +303,7 @@ topInstantiate orig sigma , text "tvs" <+> ppr tvs , text "theta" <+> ppr theta , text "type" <+> debugPprType body_ty - , text "with" <+> vcat (map debugPprType inst_tv_tys) + , text "with" <+> ppr inst_tvs , text "theta:" <+> ppr inst_theta ]) ; return (wrap2 <.> wrap1, inner_body) } ===================================== compiler/GHC/Tc/Utils/TcMType.hs ===================================== @@ -29,7 +29,7 @@ module GHC.Tc.Utils.TcMType ( newOpenBoxedTypeKind, newMetaKindVar, newMetaKindVars, newMetaTyVarTyAtLevel, newConcreteTyVarTyAtLevel, substConcreteTvOrigin, - newAnonMetaTyVar, newConcreteTyVar, + newAnonMetaTyVar, newConcreteTyVar, mkConcreteInfo, cloneMetaTyVar, cloneMetaTyVarWithInfo, newCycleBreakerTyVar, @@ -58,7 +58,6 @@ module GHC.Tc.Utils.TcMType ( newMetaTyVars, newMetaTyVarX, newMetaTyVarsX, newMetaTyVarBndrsX, newMetaTyVarTyVarX, newTyVarTyVar, cloneTyVarTyVar, - newConcreteTyVarX, newPatTyVar, newSkolemTyVar, newWildCardX, -------------------------------- @@ -714,25 +713,28 @@ used for ScopedTypeVariables in patterns, to make sure these type variables only refer to other type variables, but this restriction was dropped, and ScopedTypeVariables can now refer to full types (GHC Proposal 29). + +Note [Name of a unification variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We give unification variables a /System/ Name, which is eagerly elmininated +the the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and +GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) + +Note [Name of an instantiated type variable] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At the moment we give a unification variable a System Name, which +influences the way it is tidied; see TypeRep.tidyTyVarBndr. -} newMetaTyVarName :: FastString -> TcM Name --- Makes a /System/ Name, which is eagerly eliminated by --- the unifier; see GHC.Tc.Utils.Unify.nicer_to_update_tv1, and --- GHC.Tc.Solver.Equality.canEqTyVarTyVar (nicer_to_update_tv2) +-- Makes a /System/ Name; see Note [Name of a unification variable] newMetaTyVarName str = newSysName (mkTyVarOccFS str) cloneMetaTyVarName :: Name -> TcM Name +-- See Note [Name of an instantiated type variable] cloneMetaTyVarName name = newSysName (nameOccName name) - -- See Note [Name of an instantiated type variable] - -{- Note [Name of an instantiated type variable] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -At the moment we give a unification variable a System Name, which -influences the way it is tidied; see TypeRep.tidyTyVarBndr. --} metaInfoToTyVarName :: MetaInfo -> FastString metaInfoToTyVarName meta_info = @@ -795,18 +797,21 @@ newConcreteTyVar :: HasDebugCallStack => ConcreteTvOrigin -> FastString -> TcKind -> TcM TcTyVar newConcreteTyVar reason fs kind = assertPpr (isConcreteType kind) assert_msg $ - do { th_lvl <- getThLevel - ; if - -- See [Wrinkle: Typed Template Haskell] - -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - | TypedBrack _ <- th_lvl - -> newNamedAnonMetaTyVar fs TauTv kind - - | otherwise - -> newNamedAnonMetaTyVar fs (ConcreteTv reason) kind } + do { info <- mkConcreteInfo reason + ; newNamedAnonMetaTyVar fs info kind } where assert_msg = text "newConcreteTyVar: non-concrete kind" <+> ppr kind +mkConcreteInfo :: ConcreteTvOrigin -> TcM MetaInfo +-- Usually returns (ConcreteTv origin); but if we are in a typed +-- Template Haskell bracket, return TauTv +-- See [Wrinkle: Typed Template Haskell] in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete +mkConcreteInfo conc_origin + = do { th_lvl <- getThLevel + ; case th_lvl of + TypedBrack {} -> return TauTv + _ -> return (ConcreteTv conc_origin) } + newPatTyVar :: Name -> Kind -> TcM TcTyVar newPatTyVar name kind = do { details <- newMetaDetails TauTv @@ -981,18 +986,13 @@ newOpenFlexiTyVar -- in GHC.Tc.Utils.Concrete. newOpenFlexiFRRTyVar :: FixedRuntimeRepContext -> TcM TcTyVar newOpenFlexiFRRTyVar frr_ctxt - = do { th_lvl <- getThLevel - ; case th_lvl of - { TypedBrack _ -- See [Wrinkle: Typed Template Haskell] - -> newOpenFlexiTyVar -- in Note [hasFixedRuntimeRep] in GHC.Tc.Utils.Concrete. - ; _ -> - mdo { let conc_orig = ConcreteFRR $ + = mdo { let conc_orig = ConcreteFRR $ FixedRuntimeRepOrigin { frr_context = frr_ctxt , frr_type = mkTyVarTy tv } - ; rr <- mkTyVarTy <$> newConcreteTyVar conc_orig (fsLit "cx") runtimeRepTy - ; tv <- newFlexiTyVar (mkTYPEapp rr) - ; return tv } } } + ; rr_tv <- newConcreteTyVar conc_orig (fsLit "cx") runtimeRepTy + ; tv <- newFlexiTyVar (mkTYPEapp (mkTyVarTy rr_tv)) + ; return tv } -- | See 'newOpenFlexiFRRTyVar'. newOpenFlexiFRRTyVarTy :: FixedRuntimeRepContext -> TcM TcType View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e62e731ae896667b0b6099b49725147… -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/e62e731ae896667b0b6099b49725147… You're receiving this email because of your account on gitlab.haskell.org.

1 0