Andreas Klebinger pushed to branch wip/andreask/reentrant-tys at Glasgow Haskell Compiler / GHC

Commits:

10 changed files:

Changes:

  • compiler/GHC/Core/TyCon.hs
    ... ... @@ -830,7 +830,7 @@ The tyConUpdatable flag is controlled by the {-# RECOMPUTING T #-} pragma.
    830 830
    831 831
    832 832 
     defaultTyConFlags :: TyConFlags
    833 
    -defaultTyConFlags = TyConFlags { tyConUpdatable = False }
    833 
    +defaultTyConFlags = TyConFlags { tyConUpdatable = True }
    834 834
    835 835 
     instance Binary TyConFlags where
    836 836 
         put_ bh (TyConFlags updatable) = put_ bh updatable

  • compiler/GHC/CoreToStg.hs
    ... ... @@ -32,6 +32,7 @@ import GHC.Types.Id.Make ( coercionTokenId )
    32 32 
     import GHC.Types.Id
    33 33 
     import GHC.Types.Id.Info
    34 34 
     import GHC.Types.CostCentre
    35 
    +import GHC.Types.Demand    ( isAtMostOnceDmd )
    35 36 
     import GHC.Types.Tickish
    36 37 
     import GHC.Types.Var.Env
    37 38 
     import GHC.Types.Name   ( isExternalName )
    ... ... @@ -354,7 +355,7 @@ coreToTopStgRhs opts this_mod ccs (bndr, rhs)
    354 355 
            ; let (stg_rhs, ccs') =
    355 356 
                    mkTopStgRhs (allowTopLevelConApp (coreToStg_platform opts) (coreToStg_ExternalDynamicRefs opts))
    356 357 
                                (coreToStg_AutoSccsOnIndividualCafs opts)
    357 
    -                           this_mod ccs bndr new_rhs
    358 
    +                           this_mod ccs (mkStgUpdateFlag bndr new_rhs) bndr new_rhs
    358 359 
                  stg_arity =
    359 360 
                    stgRhsArity stg_rhs
    360 361
    ... ... @@ -704,7 +705,7 @@ coreToStgRhs :: (Id,CoreExpr)
    704 705
    705 706 
     coreToStgRhs (bndr, rhs) = do
    706 707 
         new_rhs <- coreToMkStgRhs bndr rhs
    707 
    -    return (mkStgRhs bndr new_rhs)
    708 
    +    return (mkStgRhs (mkStgUpdateFlag bndr new_rhs) new_rhs)
    708 709
    709 710 
     -- Convert the RHS of a binding from Core to STG. This is a wrapper around
    710 711 
     -- coreToStgExpr that can handle value lambdas.
    ... ... @@ -722,6 +723,24 @@ coreToMkStgRhs bndr expr = do
    722 723 
               }
    723 724 
         pure mk_rhs
    724 725
    726 
    +mkStgUpdateFlag :: Id -> MkStgRhs -> UpdateFlag
    727 
    +mkStgUpdateFlag bndr (MkStgRhs bndrs _rhs typ is_join)
    728 
    +  | is_join                             = JumpedTo
    729 
    +  | not (null bndrs)                    = ReEntrant
    730 
    +  | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
    731 
    +  | non_updatable_tycon                 = ReEntrant
    732 
    +  | otherwise                           = Updatable
    733 
    +  where
    734 
    +    non_updatable_tycon
    735 
    +      | isDataConId bndr = False
    736 
    +      | otherwise =
    737 
    +        case splitTyConApp_maybe typ of
    738 
    +          Just (tycon, _) ->
    739 
    +            if not (tyConUpdatable (tyConFlags tycon))
    740 
    +              then pprTrace "nonUpdatableTyCon:" (ppr tycon) True
    741 
    +              else False
    742 
    +          Nothing         -> False
    743 
    +
    725 744 
     -- ---------------------------------------------------------------------------
    726 745 
     -- A monad for the core-to-STG pass
    727 746 
     -- ---------------------------------------------------------------------------

  • compiler/GHC/Stg/Make.hs
    ... ... @@ -19,8 +19,8 @@ import GHC.Stg.Utils (stripStgTicksTop)
    19 19 
     import GHC.Types.Id
    20 20 
     import GHC.Types.Name
    21 21 
     import GHC.Types.CostCentre
    22 
    -import GHC.Types.Demand    ( isAtMostOnceDmd )
    23 22 
     import GHC.Types.Tickish
    23 
    +import GHC.Types.Demand (isAtMostOnceDmd)
    24 24
    25 25 
     -- Represents the RHS of a binding for use with mk(Top)StgRhs and
    26 26 
     -- mk(Top)StgRhsCon_maybe.
    ... ... @@ -36,8 +36,8 @@ data MkStgRhs = MkStgRhs
    36 36 
     -- appended to `CollectedCCs` argument.
    37 37 
     mkTopStgRhs :: (Module -> DataCon -> [StgArg] -> Bool)
    38 38 
                 -> Bool -> Module -> CollectedCCs
    39 
    -            -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
    40 
    -mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
    39 
    +            -> UpdateFlag -> Id -> MkStgRhs -> (StgRhs, CollectedCCs)
    40 
    +mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs upd_flag_core bndr mk_rhs@(MkStgRhs bndrs rhs typ _)
    41 41 
       -- try to make a StgRhsCon first
    42 42 
       | Just rhs_con <- mkTopStgRhsCon_maybe (allow_toplevel_con_app this_mod) mk_rhs
    43 43 
       = ( rhs_con, ccs )
    ... ... @@ -46,7 +46,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd
    46 46 
       = -- The list of arguments is non-empty, so not CAF
    47 47 
         ( StgRhsClosure noExtFieldSilent
    48 48 
                         dontCareCCS
    49 
    -                    ReEntrant
    49 
    +                    upd_flag
    50 50 
                         bndrs rhs typ
    51 51 
         , ccs )
    52 52
    ... ... @@ -65,7 +65,7 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd
    65 65
    66 66 
       where
    67 67 
         upd_flag | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
    68 
    -             | otherwise                           = Updatable
    68 
    +             | otherwise                           = upd_flag_core
    69 69
    70 70 
         -- CAF cost centres generated for -fcaf-all
    71 71 
         caf_cc = mkAutoCC bndr modl
    ... ... @@ -81,8 +81,8 @@ mkTopStgRhs allow_toplevel_con_app opt_AutoSccsOnIndividualCafs this_mod ccs bnd
    81 81
    82 82 
     -- Generate a non-top-level RHS. Cost-centre is always currentCCS,
    83 83 
     -- see Note [Cost-centre initialization plan].
    84 
    -mkStgRhs :: Id -> MkStgRhs -> StgRhs
    85 
    -mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
    84 
    +mkStgRhs :: UpdateFlag -> MkStgRhs -> StgRhs
    85 
    +mkStgRhs upd_flag mk_rhs@(MkStgRhs bndrs rhs typ _is_join)
    86 86 
       -- try to make a StgRhsCon first
    87 87 
       | Just rhs_con <- mkStgRhsCon_maybe mk_rhs
    88 88 
       = rhs_con
    ... ... @@ -91,11 +91,6 @@ mkStgRhs bndr mk_rhs@(MkStgRhs bndrs rhs typ is_join)
    91 91 
       = StgRhsClosure noExtFieldSilent
    92 92 
                       currentCCS
    93 93 
                       upd_flag bndrs rhs typ
    94 
    -  where
    95 
    -    upd_flag | is_join                             = JumpedTo
    96 
    -             | not (null bndrs)                    = ReEntrant
    97 
    -             | isAtMostOnceDmd (idDemandInfo bndr) = SingleEntry
    98 
    -             | otherwise                           = Updatable
    99 94
    100 95 
       {-
    101 96 
         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
    785 785 
        = do { (first_group, group_tail) <- findSplice decls
    786 786
    787 787 
                     -- Rename the declarations
    788 
    -        ; (tcg_env, HsGroup { hs_tyclds = tycl_decls
    789 
    -                            , hs_derivds = deriv_decls
    790 
    -                            , hs_fords  = for_decls
    791 
    -                            , hs_defds  = def_decls
    792 
    -                            , hs_ruleds = rule_decls
    793 
    -                            , hs_annds  = _
    794 
    -                            , hs_valds  = XValBindsLR (HsVBG val_binds val_sigs) })
    788 
    +        ; (tcg_env0, HsGroup { hs_tyclds = tycl_decls
    789 
    +                             , hs_derivds = deriv_decls
    790 
    +                             , hs_fords  = for_decls
    791 
    +                             , hs_defds  = def_decls
    792 
    +                             , hs_ruleds = rule_decls
    793 
    +                             , hs_annds  = _
    794 
    +                             , hs_recomputing_tyds = recomputing_tycons
    795 
    +                             , hs_valds  = XValBindsLR (HsVBG val_binds val_sigs) })
    795 796 
                   <- rnTopSrcDecls first_group
    796 797
    798 
    +        ; let tcg_env = extendRecomputingTyCons recomputing_tycons tcg_env0
    799 
    +
    797 800 
             ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {
    798 801 
                   -- NB: setGblEnv **before** captureTopConstraints so that
    799 802 
                   -- if the latter reports errors, it knows what's in scope
    ... ... @@ -1699,6 +1702,13 @@ rnTopSrcDecls group
    1699 1702 
             return (tcg_env', rn_decls)
    1700 1703 
        }
    1701 1704
    1705 
    +extendRecomputingTyCons :: [LIdP GhcRn] -> TcGblEnv -> TcGblEnv
    1706 
    +extendRecomputingTyCons tycons tcg_env
    1707 
    +  = tcg_env
    1708 
    +      { tcg_recomputing_tycons =
    1709 
    +          tcg_recomputing_tycons tcg_env `unionNameSet`
    1710 
    +          mkNameSet (map unLoc tycons) }
    1711 
    +
    1702 1712 
     tcTopSrcDecls :: HsGroup GhcRn -> TcM (TcGblEnv, TcLclEnv)
    1703 1713 
     tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
    1704 1714 
                              hs_derivds = deriv_decls,
    ... ... @@ -1706,9 +1716,12 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
    1706 1716 
                              hs_defds  = default_decls,
    1707 1717 
                              hs_annds  = annotation_decls,
    1708 1718 
                              hs_ruleds = rule_decls,
    1719 
    +                         hs_recomputing_tyds = recomputing_tycons,
    1709 1720 
                              hs_valds  = hs_val_binds@(XValBindsLR
    1710 1721 
                                                   (HsVBG val_binds val_sigs)) })
    1711 
    - = do {         -- Type-check the type and class decls, and all imported decls
    1722 
    + = do { tcg_env <- getGblEnv
    1723 
    +      ; setGblEnv (extendRecomputingTyCons recomputing_tycons tcg_env) $ do {
    1724 
    +                -- Type-check the type and class decls, and all imported decls
    1712 1725 
                     -- The latter come in via tycl_decls
    1713 1726 
             traceTc "Tc2 (src)" empty ;
    1714 1727
    ... ... @@ -1785,7 +1798,7 @@ tcTopSrcDecls (HsGroup { hs_tyclds = tycl_decls,
    1785 1798 
             addUsedGREs NoDeprecationWarnings (bagToList fo_gres) ;
    1786 1799
    1787 1800 
             return (tcg_env', tcl_env)
    1788 
    -    }}}}}
    1801 
    +    }}}}}}
    1789 1802
    1790 1803 
     tcTopSrcDecls _ = panic "tcTopSrcDecls: ValBindsIn"
    1791 1804

  • compiler/GHC/Tc/TyCl.hs
    ... ... @@ -3595,6 +3595,13 @@ tcDataDefn err_ctxt roles_info tc_name
    3595 3595 
                        ; res_kind       <- zonkTcTypeToTypeX   res_kind
    3596 3596 
                        ; return (kind, bndrs, stupid_theta, res_kind) }
    3597 3597
    3598 
    +       ; tcg_env <- getGblEnv
    3599 
    +       ; let tycon_flags
    3600 
    +               | tc_name `elemNameSet` tcg_recomputing_tycons tcg_env
    3601 
    +               = defaultTyConFlags { tyConUpdatable = False }
    3602 
    +               | otherwise
    3603 
    +               = defaultTyConFlags
    3604 
    +
    3598 3605 
            ; tycon <- fixM $ \ rec_tycon -> do
    3599 3606 
                  { data_cons <- tcConDecls DDataType rec_tycon tc_bndrs res_kind cons
    3600 3607 
                  ; tc_rhs    <- mk_tc_rhs hsc_src rec_tycon data_cons
    ... ... @@ -3603,7 +3610,7 @@ tcDataDefn err_ctxt roles_info tc_name
    3603 3610 
                                       bndrs nb_eta
    3604 3611 
                                       res_kind
    3605 3612 
                                       (roles_info tc_name)
    3606 
    -                                  defaultTyConFlags
    3613 
    +                                  tycon_flags
    3607 3614 
                                       (fmap (typeCheckCType . unLoc) cType)
    3608 3615 
                                       stupid_theta tc_rhs
    3609 3616 
                                       (VanillaAlgTyCon tc_rep_nm)

  • compiler/GHC/Tc/Types.hs
    ... ... @@ -644,6 +644,7 @@ data TcGblEnv
    644 644 
             tcg_rules     :: [LRuleDecl GhcTc],  -- ...Rules
    645 645 
             tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports
    646 646 
             tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms
    647 
    +        tcg_recomputing_tycons :: NameSet,    -- ...TyCons marked by RECOMPUTING pragmas
    647 648
    648 649 
             tcg_hdr_info   :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)),
    649 650 
             -- ^ 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 =
    384 384 
               , tcg_rules               = []
    385 385 
               , tcg_fords               = []
    386 386 
               , tcg_patsyns             = []
    387 
    +          , tcg_recomputing_tycons  = emptyNameSet
    387 388 
               , tcg_merged              = []
    388 389 
               , tcg_dfun_n              = dfun_n_var
    389 390 
               , tcg_zany_n              = zany_n_var

  • testsuite/tests/perf/should_run/T27114.hs
    1 
    +{-# OPTIONS_GHC
    2 
    +
    3 
    +-dsuppress-uniques
    4 
    +
    5 
    + #-}
    6 
    +module Main where
    7 
    +
    8 
    +import System.Environment
    9 
    +
    10 
    +foo :: Foldable t => t a -> Int
    11 
    +foo = undefined
    12 
    +
    13 
    +{-# RECOMPUTING Nats #-}
    14 
    +data Nats = Nats Int Nats
    15 
    +
    16 
    +{-# NOINLINE loop #-}
    17 
    +loop :: Int -> Nats -> (Int -> IO ()) -> IO ()
    18 
    +loop 0 _           _ = return ()
    19 
    +loop n (Nats i is) k = k i >> loop (n - 1) is k
    20 
    +
    21 
    +main :: IO ()
    22 
    +main = do
    23 
    +    args <- getArgs
    24 
    +    let count = case args of
    25 
    +                    (a:args) -> read $ filter (/= '_') a
    26 
    +                    _ -> 10_000_000
    27 
    +
    28 
    +    let nats n = Nats n (nats (n + 1))
    29 
    +    let ele_action x = if (x `mod` (count `div` 10)) == 0 then print x else seq x (pure ())
    30 
    +    loop count (nats 0) ele_action
    31 
    +    -- With saring for @Nats@ disabled we will not retain the fully materialized nats data structure.
    32 
    +    -- Instead the second loop will recompute it.
    33 
    +    loop count (nats 0) ele_action
    34 
    +

  • testsuite/tests/perf/should_run/T27114.stdout
    1 
    +0
    2 
    +1000000
    3 
    +2000000
    4 
    +3000000
    5 
    +4000000
    6 
    +5000000
    7 
    +6000000
    8 
    +7000000
    9 
    +8000000
    10 
    +9000000
    11 
    +0
    12 
    +1000000
    13 
    +2000000
    14 
    +3000000
    15 
    +4000000
    16 
    +5000000
    17 
    +6000000
    18 
    +7000000
    19 
    +8000000
    20 
    +9000000

  • testsuite/tests/perf/should_run/all.T
    ... ... @@ -441,3 +441,10 @@ test('SpecTyFamRun', [ grep_errmsg(r'foo')
    441 441 
                         , collect_stats('bytes allocated', 5)],
    442 442 
          multimod_compile_and_run,
    443 443 
          ['SpecTyFamRun', '-O2'])
    444 
    +
    445 
    +test('T27114',
    446 
    +     [collect_runtime_residency(50),
    447 
    +      only_ways(['normal'])
    448 
    +      ],
    449 
    +     compile_and_run,
    450 
    +     ['-O'])
    \ No newline at end of file

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications · Help