Andreas Klebinger pushed to branch wip/andreask/reentrant-tys at Glasgow Haskell Compiler / GHC Commits: 89da6c0f by Andreas Klebinger at 2026-04-07T12:29:28+00:00 Working prototype - - - - - 10 changed files: - compiler/GHC/Core/TyCon.hs - compiler/GHC/CoreToStg.hs - compiler/GHC/Stg/Make.hs - compiler/GHC/Tc/Module.hs - compiler/GHC/Tc/TyCl.hs - compiler/GHC/Tc/Types.hs - compiler/GHC/Tc/Utils/Monad.hs - + testsuite/tests/perf/should_run/T27114.hs - + testsuite/tests/perf/should_run/T27114.stdout - testsuite/tests/perf/should_run/all.T Changes: ===================================== compiler/GHC/Core/TyCon.hs ===================================== @@ -830,7 +830,7 @@ The tyConUpdatable flag is controlled by the {-# RECOMPUTING T #-} pragma. defaultTyConFlags :: TyConFlags -defaultTyConFlags = TyConFlags { tyConUpdatable = False } +defaultTyConFlags = TyConFlags { tyConUpdatable = True } instance Binary TyConFlags where put_ bh (TyConFlags updatable) = put_ bh updatable ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -32,6 +32,7 @@ import GHC.Types.Id.Make ( coercionTokenId ) import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.CostCentre +import GHC.Types.Demand ( isAtMostOnceDmd ) import GHC.Types.Tickish import GHC.Types.Var.Env import GHC.Types.Name ( isExternalName ) @@ -354,7 +355,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs) ; let (stg_rhs, ccs') = mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts)) (coreToStg_AutoSccsOnIndividualCafs opts) - this_mod ccs bndr new_rhs + this_mod ccs (mkStgUpdateFlag bndr new_rhs) bndr new_rhs stg_arity = stgRhsArity stg_rhs @@ -704,7 +705,7 @@ coreToStgRhs :: (Id,CoreExpr) coreToStgRhs (bndr, rhs) = do new_rhs <- coreToMkStgRhs bndr rhs - return (mkStgRhs bndr new_rhs) + return (mkStgRhs (mkStgUpdateFlag bndr new_rhs) new_rhs) -- Convert the RHS of a binding from Core to STG. This is a wrapper around -- coreToStgExpr that can handle value lambdas. @@ -722,6 +723,24 @@ coreToMkStgRhs bndr expr = do } pure mk_rhs +mkStgUpdateFlag :: Id -> MkStgRhs -> UpdateFlag +mkStgUpdateFlag bndr (MkStgRhs bndrs _rhs typ is_join) + | is_join = JumpedTo + | not (null bndrs) = ReEntrant + | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry + | non_updatable_tycon = ReEntrant + | otherwise = Updatable + where + non_updatable_tycon + | isDataConId bndr = False + | otherwise = + case splitTyConApp_maybe typ of + Just (tycon, _) -> + if not (tyConUpdatable (tyConFlags tycon)) + then pprTrace "nonUpdatableTyCon:" (ppr tycon) True + else False + Nothing -> False + -- --------------------------------------------------------------------------- -- A monad for the core-to-STG pass -- --------------------------------------------------------------------------- ===================================== compiler/GHC/Stg/Make.hs ===================================== @@ -19,8 +19,8 @@ import GHC.Stg.Utils (stripStgTicksTop) import GHC.Types.Id import GHC.Types.Name import GHC.Types.CostCentre -import GHC.Types.Demand ( isAtMostOnceDmd ) import GHC.Types.Tickish +import GHC.Types.Demand (isAtMostOnceDmd) -- Represents the RHS of a binding for use with mk(Top)StgRhs and -- mk(Top)StgRhsCon_maybe. @@ -36,8 +36,8 @@ data MkStgRhs = MkStgRhs -- appended to `CollectedCCs` argument. mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool) -> Bool -> Module -> CollectedCCs - -> Id -> MkStgRhs -> (StgRhs, CollectedCCs) -mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _) + -> UpdateFlag -> Id -> MkStgRhs -> (StgRhs, CollectedCCs) +mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs upd_flag_core bndr mk_rhs@(MkStgRhs bndrs rhs typ _) -- try to make a StgRhsCon first | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs = ( rhs_con, ccs ) @@ -46,7 +46,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd = -- The list of arguments is non-empty, so not CAF ( StgRhsClosure noExtFieldSilent dontCareCCS - ReEntrant + upd_flag bndrs rhs typ , ccs ) @@ -65,7 +65,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd where upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable + | otherwise = upd_flag_core -- CAF cost centres generated for -fcaf-all caf_cc = mkAutoCC bndr modl @@ -81,8 +81,8 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd -- Generate a non-top-level RHS. Cost-centre is always currentCCS, -- see Note [Cost-centre initialization plan]. -mkStgRhs :: Id -> MkStgRhs -> StgRhs -mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) +mkStgRhs :: UpdateFlag -> MkStgRhs -> StgRhs +mkStgRhs upd_flag mk_rhs@(MkStgRhs bndrs rhs typ _is_join) -- try to make a StgRhsCon first | Just rhs_con <- mkStgRhsCon_maybe mk_rhs = rhs_con @@ -91,11 +91,6 @@ mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join) = StgRhsClosure noExtFieldSilent currentCCS upd_flag bndrs rhs typ - where - upd_flag | is_join = JumpedTo - | not (null bndrs) = ReEntrant - | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry - | otherwise = Updatable {- SDM: disabled. Eval/Apply can't handle functions with arity zero very ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -785,15 +785,18 @@ tcRnHsBootDecls boot_or_sig decls = do { (first_group, group_tail) <- findSplice decls -- Rename the declarations - ; (tcg_env, HsGroup { hs_tyclds = tycl_decls - , hs_derivds = deriv_decls - , hs_fords = for_decls - , hs_defds = def_decls - , hs_ruleds = rule_decls - , hs_annds = _ - , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) }) + ; (tcg_env0, HsGroup { hs_tyclds = tycl_decls + , hs_derivds = deriv_decls + , hs_fords = for_decls + , hs_defds = def_decls + , hs_ruleds = rule_decls + , hs_annds = _ + , hs_recomputing_tyds = recomputing_tycons + , hs_valds = XValBindsLR (HsVBG val_binds val_sigs) }) <- rnTopSrcDecls first_group + ; let tcg_env = extendRecomputingTyCons recomputing_tycons tcg_env0 + ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do { -- NB: setGblEnv **before** captureTopConstraints so that -- if the latter reports errors, it knows what's in scope @@ -1699,6 +1702,13 @@ rnTopSrcDecls group return (tcg_env', rn_decls) } +extendRecomputingTyCons :: [LIdP GhcRn] -> TcGblEnv -> TcGblEnv +extendRecomputingTyCons tycons tcg_env + = tcg_env + { tcg_recomputing_tycons = + tcg_recomputing_tycons tcg_env `unionNameSet` + mkNameSet (map unLoc tycons) } + tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv) tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_derivds = deriv_decls, @@ -1706,9 +1716,12 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, hs_defds = default_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, + hs_recomputing_tyds = recomputing_tycons, hs_valds = hs_val_binds@(XValBindsLR (HsVBG val_binds val_sigs)) }) - = do { -- Type-check the type and class decls, and all imported decls + = do { tcg_env <- getGblEnv + ; setGblEnv (extendRecomputingTyCons recomputing_tycons tcg_env) $ do { + -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc "Tc2 (src)" empty ; @@ -1785,7 +1798,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls, addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ; return (tcg_env', tcl_env) - }}}}} + }}}}}} tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn" ===================================== compiler/GHC/Tc/TyCl.hs ===================================== @@ -3595,6 +3595,13 @@ tcDataDefn err_ctxt roles_info tc_name ; res_kind <- zonkTcTypeToTypeX res_kind ; return (kind, bndrs, stupid_theta, res_kind) } + ; tcg_env <- getGblEnv + ; let tycon_flags + | tc_name `elemNameSet` tcg_recomputing_tycons tcg_env + = defaultTyConFlags { tyConUpdatable = False } + | otherwise + = defaultTyConFlags + ; tycon <- fixM $ \ rec_tycon -> do { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons ; tc_rhs <- mk_tc_rhs hsc_src rec_tycon data_cons @@ -3603,7 +3610,7 @@ tcDataDefn err_ctxt roles_info tc_name bndrs nb_eta res_kind (roles_info tc_name) - defaultTyConFlags + tycon_flags (fmap (typeCheckCType . unLoc) cType) stupid_theta tc_rhs (VanillaAlgTyCon tc_rep_nm) ===================================== compiler/GHC/Tc/Types.hs ===================================== @@ -644,6 +644,7 @@ data TcGblEnv tcg_rules :: [LRuleDecl GhcTc], -- ...Rules tcg_fords :: [LForeignDecl GhcTc], -- ...Foreign import & exports tcg_patsyns :: [PatSyn], -- ...Pattern synonyms + tcg_recomputing_tycons :: NameSet, -- ...TyCons marked by RECOMPUTING pragmas tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)), -- ^ Maybe Haddock header docs and Maybe located module name ===================================== compiler/GHC/Tc/Utils/Monad.hs ===================================== @@ -384,6 +384,7 @@ initTcGblEnv hsc_env hsc_src keep_rn_syntax mod loc = , tcg_rules = [] , tcg_fords = [] , tcg_patsyns = [] + , tcg_recomputing_tycons = emptyNameSet , tcg_merged = [] , tcg_dfun_n = dfun_n_var , tcg_zany_n = zany_n_var ===================================== testsuite/tests/perf/should_run/T27114.hs ===================================== @@ -0,0 +1,34 @@ +{-# OPTIONS_GHC + +-dsuppress-uniques + + #-} +module Main where + +import System.Environment + +foo :: Foldable t => t a -> Int +foo = undefined + +{-# RECOMPUTING Nats #-} +data Nats = Nats Int Nats + +{-# NOINLINE loop #-} +loop :: Int -> Nats -> (Int -> IO ()) -> IO () +loop 0 _ _ = return () +loop n (Nats i is) k = k i >> loop (n - 1) is k + +main :: IO () +main = do + args <- getArgs + let count = case args of + (a:args) -> read $ filter (/= '_') a + _ -> 10_000_000 + + let nats n = Nats n (nats (n + 1)) + let ele_action x = if (x `mod` (count `div` 10)) == 0 then print x else seq x (pure ()) + loop count (nats 0) ele_action + -- With saring for @Nats@ disabled we will not retain the fully materialized nats data structure. + -- Instead the second loop will recompute it. + loop count (nats 0) ele_action + ===================================== testsuite/tests/perf/should_run/T27114.stdout ===================================== @@ -0,0 +1,20 @@ +0 +1000000 +2000000 +3000000 +4000000 +5000000 +6000000 +7000000 +8000000 +9000000 +0 +1000000 +2000000 +3000000 +4000000 +5000000 +6000000 +7000000 +8000000 +9000000 ===================================== testsuite/tests/perf/should_run/all.T ===================================== @@ -441,3 +441,10 @@ test('SpecTyFamRun', [ grep_errmsg(r'foo') , collect_stats('bytes allocated', 5)], multimod_compile_and_run, ['SpecTyFamRun', '-O2']) + +test('T27114', + [collect_runtime_residency(50), + only_ways(['normal']) + ], + compile_and_run, + ['-O']) \ No newline at end of file View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89da6c0f793d9d6ecc286fab30543b50... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/89da6c0f793d9d6ecc286fab30543b50... You're receiving this email because of your account on gitlab.haskell.org.