[Git][ghc/ghc][wip/T20749] Try fixing allocation regressions
Sebastian Graf (@sgraf812)
gitlab at gitlab.haskell.org
Mon Sep 4 09:58:08 UTC 2023
Sebastian Graf pushed to branch wip/T20749 at Glasgow Haskell Compiler / GHC
Commits:
32df3d77 by Jaro Reinders at 2023-09-04T11:57:48+02:00
Try fixing allocation regressions
- - - - -
4 changed files:
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Stg/InferTags/Rewrite.hs
- compiler/GHC/Utils/Misc.hs
Changes:
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -55,7 +55,7 @@ module GHC.Core.Type (
splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,
splitForAllTyCoVar_maybe, splitForAllTyCoVar,
splitForAllTyVar_maybe, splitForAllCoVar_maybe,
- splitPiTy_maybe, splitPiTy, splitPiTys,
+ splitPiTy_maybe, splitPiTy, splitPiTys, collectPiTyBinders,
getRuntimeArgTys,
mkTyConBindersPreferAnon,
mkPiTy, mkPiTys,
@@ -293,6 +293,7 @@ import GHC.Data.FastString
import Control.Monad ( guard )
import GHC.Data.Maybe ( orElse, isJust )
+import GHC.List (build)
-- $type_classification
-- #type_classification#
@@ -2005,6 +2006,18 @@ splitPiTys ty = split ty ty []
split orig_ty ty bs | Just ty' <- coreView ty = split orig_ty ty' bs
split orig_ty _ bs = (reverse bs, orig_ty)
+collectPiTyBinders :: Type -> [PiTyBinder]
+collectPiTyBinders ty = build $ \c n ->
+ let
+ split (ForAllTy b res) = Named b `c` split res
+ split (FunTy { ft_af = af, ft_mult = w, ft_arg = arg, ft_res = res })
+ = Anon (Scaled w arg) af `c` split res
+ split ty | Just ty' <- coreView ty = split ty'
+ split _ = n
+ in
+ split ty
+{-# INLINE collectPiTyBinders #-}
+
-- | Extracts a list of run-time arguments from a function type,
-- looking through newtypes to the right of arrows.
--
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -1983,7 +1983,7 @@ exprIsHNFlike is_con is_con_unf e
, Just str_marks <- dataConRepStrictness_maybe dc -- with strict fields
, assert (val_args `leLength` str_marks) True
, val_args `equalLength` str_marks -- in a saturated app
- = all3Prefix check_field str_marks val_arg_tys val_args
+ = all3Prefix check_field str_marks (mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders (idType id))) val_args
-- Now all applications except saturated DataCon apps with strict fields
| idArity id > length val_args
@@ -1993,14 +1993,14 @@ exprIsHNFlike is_con is_con_unf e
-- Hence we only need to check unlifted val_args here.
-- NB: We assume that CONLIKEs are lazy, which is their entire
-- point.
- = all2Prefix check_arg val_arg_tys val_args
+ = all2Prefix check_arg (mapMaybe anonPiTyBinderType_maybe (collectPiTyBinders (idType id))) val_args
| otherwise
= False
where
- fun_ty = idType id
- (arg_tys,_) = splitPiTys fun_ty
- val_arg_tys = mapMaybe anonPiTyBinderType_maybe arg_tys
+ -- fun_ty = idType id
+ -- arg_tys = collectPiTyBinders fun_ty
+ -- val_arg_tys = mapMaybe anonPiTyBinderType_maybe arg_tys
-- val_arg_tys = map exprType val_args, but much less costly.
-- The obvious definition regresses T16577 by 30% so we don't do it.
@@ -2014,6 +2014,7 @@ exprIsHNFlike is_con is_con_unf e
= isMarkedStrict str || mightBeUnliftedType a_ty ==> is_hnf_like a
a ==> b = not a || b
infixr 1 ==>
+{-# INLINE exprIsHNFlike #-}
{-
Note [exprIsHNF Tick]
=====================================
compiler/GHC/Stg/InferTags/Rewrite.hs
=====================================
@@ -368,7 +368,7 @@ rewriteRhs (_id, _tagSig) (StgRhsCon ccs con cn ticks args typ) = {-# SCC rewrit
fvs <- fvArgs args
-- lcls <- getFVs
-- pprTraceM "RhsClosureConversion" (ppr (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) $$ text "lcls:" <> ppr lcls)
- return $! (StgRhsClosure fvs ccs ReEntrant [] $! conExpr) typ
+ return $! (StgRhsClosure fvs ccs Updatable [] $! conExpr) typ
rewriteRhs _binding (StgRhsClosure fvs ccs flag args body typ) = do
withBinders NotTopLevel args $
withClosureLcls fvs $
=====================================
compiler/GHC/Utils/Misc.hs
=====================================
@@ -663,20 +663,24 @@ all2Prefix :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-- ^ `all2Prefix p xs ys` is a fused version of `and $ zipWith2 p xs ys`.
-- So if one list is shorter than the other, `p` is assumed to be `True` for the
-- suffix.
-all2Prefix p xs ys = go xs ys
- where go (x:xs) (y:ys) = p x y && go xs ys
- go _ _ = True
-{-# INLINABLE all2Prefix #-}
+all2Prefix p = foldr (\x go ys' -> case ys' of (y:ys'') -> p x y && go ys''; _ -> True) (\_ -> True)
+{-# INLINE all2Prefix #-}
+-- all2Prefix p xs ys = go xs ys
+-- where go (x:xs) (y:ys) = p x y && go xs ys
+-- go _ _ = True
+-- {-# INLINABLE all2Prefix #-}
all3Prefix :: (a -> b -> c -> Bool) -> [a] -> [b] -> [c] -> Bool
-- ^ `all3Prefix p xs ys zs` is a fused version of `and $ zipWith3 p xs ys zs`.
-- So if one list is shorter than the others, `p` is assumed to be `True` for
-- the suffix.
-all3Prefix p xs ys zs = go xs ys zs
- where
- go (x:xs) (y:ys) (z:zs) = p x y z && go xs ys zs
- go _ _ _ = True
-{-# INLINABLE all3Prefix #-}
+all3Prefix p xs ys zs = foldr (\y go xs' zs' -> case (xs',zs') of (x:xs'',z:zs'') -> p x y z && go xs'' zs''; _ -> False) (\_ _ -> True) ys xs zs
+{-# INLINE all3Prefix #-}
+-- all3Prefix p xs ys zs = go xs ys zs
+-- where
+-- go (x:xs) (y:ys) (z:zs) = p x y z && go xs ys zs
+-- go _ _ _ = True
+-- {-# INLINABLE all3Prefix #-}
-- Count the number of times a predicate is true
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32df3d778e273fbcf8aa2930a3e16d8dbea13c9e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/32df3d778e273fbcf8aa2930a3e16d8dbea13c9e
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230904/d8e58000/attachment-0001.html>
More information about the ghc-commits
mailing list