diff options
Diffstat (limited to 'compiler/GHC/Core/Opt/CprAnal.hs')
| -rw-r--r-- | compiler/GHC/Core/Opt/CprAnal.hs | 22 |
1 files changed, 13 insertions, 9 deletions
diff --git a/compiler/GHC/Core/Opt/CprAnal.hs b/compiler/GHC/Core/Opt/CprAnal.hs index ddafa72b33..6863dc1358 100644 --- a/compiler/GHC/Core/Opt/CprAnal.hs +++ b/compiler/GHC/Core/Opt/CprAnal.hs @@ -25,7 +25,7 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Core.DataCon import GHC.Core.Multiplicity -import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram ) +import GHC.Core.Utils ( exprIsHNF, dumpIdInfoOfProgram, normSplitTyConApp_maybe ) import GHC.Core.Type import GHC.Core.FamInstEnv import GHC.Core.Opt.WorkWrap.Utils @@ -33,7 +33,7 @@ import GHC.Utils.Misc import GHC.Utils.Panic import GHC.Utils.Logger ( Logger, dumpIfSet_dyn, DumpFormat (..) ) import GHC.Data.Graph.UnVar -- for UnVarSet -import GHC.Data.Maybe ( isNothing ) +import GHC.Data.Maybe ( isJust ) import Control.Monad ( guard ) import Data.List ( mapAccumL ) @@ -319,10 +319,10 @@ cprAnalBind top_lvl env id rhs -- possibly trim thunk CPR info rhs_ty' -- See Note [CPR for thunks] - | stays_thunk = trimCprTy rhs_ty + | stays_thunk = trimCprTy rhs_ty -- See Note [CPR for sum types] - | returns_sum = trimCprTy rhs_ty - | otherwise = rhs_ty + | returns_local_sum = trimCprTy rhs_ty + | otherwise = rhs_ty -- See Note [Arity trimming for CPR signatures] sig = mkCprSigForArity (idArity id) rhs_ty' id' = setIdCprSig id sig @@ -334,8 +334,12 @@ cprAnalBind top_lvl env id rhs not_strict = not (isStrUsedDmd (idDemandInfo id)) -- See Note [CPR for sum types] (_, ret_ty) = splitPiTys (idType id) - not_a_prod = isNothing (splitArgType_maybe (ae_fam_envs env) ret_ty) - returns_sum = not (isTopLevel top_lvl) && not_a_prod + returns_product + | Just (tc, _, _) <- normSplitTyConApp_maybe (ae_fam_envs env) ret_ty + = isJust (tyConSingleAlgDataCon_maybe tc) + | otherwise + = False + returns_local_sum = not (isTopLevel top_lvl) && not returns_product isDataStructure :: Id -> CoreExpr -> Bool -- See Note [CPR for data structures] @@ -483,7 +487,7 @@ argCprType env arg_ty dmd = CprType 0 (go arg_ty dmd) where go ty dmd | Unbox (DataConPatContext { dcpc_dc = dc, dcpc_tc_args = tc_args }) ds - <- wantToUnbox (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd + <- wantToUnboxArg (ae_fam_envs env) MaybeArgOfInlineableFun ty dmd -- No existentials; see Note [Which types are unboxed?]) -- Otherwise we'd need to call dataConRepInstPat here and thread a -- UniqSupply. So argCprType is a bit less aggressive than it could @@ -545,7 +549,7 @@ This is all done in 'extendSigEnvForArg'. Note that - * Whether or not something unboxes is decided by 'wantToUnbox', else we may + * Whether or not something unboxes is decided by 'wantToUnboxArg', else we may get over-optimistic CPR results (e.g., from \(x :: a) -> x!). * If the demand unboxes deeply, we can give the binder a /nested/ CPR |