Simon Peyton Jones pushed to branch wip/T26425 at Glasgow Haskell Compiler / GHC Commits: f1959dfc by Simon Peyton Jones at 2025-11-26T11:58:07+00:00 Remove a quadratic-cost assertion check in mkCoreApp See the new Note [Assertion checking in mkCoreApp] - - - - - 5 changed files: - compiler/GHC/Core/Make.hs - compiler/GHC/HsToCore/Binds.hs - compiler/GHC/HsToCore/Expr.hs - compiler/GHC/HsToCore/Match.hs - testsuite/tests/unboxedsums/UbxSumUnpackedSize.hs Changes: ===================================== compiler/GHC/Core/Make.hs ===================================== @@ -151,37 +151,28 @@ mkCoreConWrapApps con args = mkCoreApps (Var (dataConWrapId con)) args -- | Construct an expression which represents the application of a number of -- expressions to another. The leftmost expression in the list is applied first -mkCoreApps :: CoreExpr -- ^ function +-- See Note [Assertion checking in mkCoreApp] +mkCoreApps :: CoreExpr -- ^ function -> [CoreExpr] -- ^ arguments -> CoreExpr -mkCoreApps fun args - = fst $ - foldl' (mkCoreAppTyped doc_string) (fun, fun_ty) args - where - doc_string = ppr fun_ty $$ ppr fun $$ ppr args - fun_ty = exprType fun +mkCoreApps fun args = foldl' mkCoreApp fun args -- | Construct an expression which represents the application of one expression -- to the other -mkCoreApp :: SDoc - -> CoreExpr -- ^ function +-- See Note [Assertion checking in mkCoreApp] +mkCoreApp :: CoreExpr -- ^ function -> CoreExpr -- ^ argument -> CoreExpr -mkCoreApp s fun arg - = fst $ mkCoreAppTyped s (fun, exprType fun) arg - --- | Construct an expression which represents the application of one expression --- paired with its type to an argument. The result is paired with its type. This --- function is not exported and used in the definition of 'mkCoreApp' and --- 'mkCoreApps'. -mkCoreAppTyped :: SDoc -> (CoreExpr, Type) -> CoreExpr -> (CoreExpr, Type) -mkCoreAppTyped _ (fun, fun_ty) (Type ty) - = (App fun (Type ty), piResultTy fun_ty ty) -mkCoreAppTyped _ (fun, fun_ty) (Coercion co) - = (App fun (Coercion co), funResultTy fun_ty) -mkCoreAppTyped d (fun, fun_ty) arg - = assertPpr (isFunTy fun_ty) (ppr fun $$ ppr arg $$ d) - (App fun arg, funResultTy fun_ty) +mkCoreApp fun arg = App fun arg + +{- Note [Assertion checking in mkCoreApp] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +At one time we had an assertion to check that the function and argument type match up, +but that turned out to take 90% of all compile time (!) when compiling test +`unboxedsums/UbxSumUnpackedSize.hs`. The reason was an unboxed sum constructor with +hundreds of foralls. It's most straightforward just to remove the assert, and +rely on Lint to discover any mis-constructed terms. +-} {- ********************************************************************* * * ===================================== compiler/GHC/HsToCore/Binds.hs ===================================== @@ -1620,7 +1620,7 @@ ds_hs_wrapper hs_wrap do { x <- newSysLocalDs (mkScaled (subMultCoRKind w_co) t) ; go c1 $ \w1 -> go c2 $ \w2 -> - let app f a = mkCoreApp (text "dsHsWrapper") f a + let app f a = mkCoreApp f a arg = w1 (Var x) in k (\e -> (Lam x (w2 (app e arg)))) } ===================================== compiler/GHC/HsToCore/Expr.hs ===================================== @@ -877,8 +877,7 @@ dsHsConLike (PatSynCon ps) | Just (builder_name, _, add_void) <- patSynBuilder ps = do { builder_id <- dsLookupGlobalId builder_name ; return (if add_void - then mkCoreApp (text "dsConLike" <+> ppr ps) - (Var builder_id) unboxedUnitExpr + then mkCoreApp (Var builder_id) unboxedUnitExpr else Var builder_id) } | otherwise = pprPanic "dsConLike" (ppr ps) ===================================== compiler/GHC/HsToCore/Match.hs ===================================== @@ -301,7 +301,7 @@ matchView (var :| vars) ty eqns@(eqn1 :| _) -- compile the view expressions ; viewExpr' <- dsExpr viewExpr ; return (mkViewMatchResult var' - (mkCoreApp (text "matchView") viewExpr' (Var var)) + (mkCoreApp viewExpr' (Var var)) match_result) } -- decompose the first pattern and leave the rest alone ===================================== testsuite/tests/unboxedsums/UbxSumUnpackedSize.hs ===================================== @@ -133,6 +133,124 @@ data U_E1 = U_E1 {-# UNPACK #-} !E1 {-# UNPACK #-} !Int8 deriving (Show) +{- In `data U_E`, the {-# UNPACK #-} !E1 gives rise to a pretty clumsy expression + for the wrapper for U_E1. Here is what it looks like when ther are only 16 + data constructors in E1, and we have just + data U_E1 = U_E1 {-# UNPACK #-} !E1 + Blimey! + +Main.$WU_E1 + = \ (conrep_t1N4 [Occ=Once1!] :: Main.E1) -> + case case conrep_t1N4 of { + Main.E1_1 -> + GHC.Internal.Types.(# _| | | | | | | | | | | | | | | #) + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + GHC.Internal.Types.(##); + Main.E1_2 -> + GHC.Internal.Types.(# |_| | | | | | | | | | | | | | #) + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + GHC.Internal.Types.(##); + Main.E1_3 -> + GHC.Internal.Types.(# | |_| | | | | | | | | | | | | #) + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @GHC.Internal.Types.ZeroBitRep + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + @(# #) + GHC.Internal.Types.(##); + + ... etc .... +-} + data U_E2 = U_E2 {-# UNPACK #-} !E2 {-# UNPACK #-} !Int8 {-# UNPACK #-} !Int8 View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f1959dfcfc2ecac6e8c91ecba9503972... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/f1959dfcfc2ecac6e8c91ecba9503972... You're receiving this email because of your account on gitlab.haskell.org.