Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC

Commits:

18 changed files:

Changes:

  • changelog.d/dynamic-trace-flags
    1 
    +section: compiler
    2 
    +synopsis: Support dynamic trace flags in RTS
    3 
    +issues: #27186
    4 
    +mrs: !15936
    5 
    +
    6 
    +description: {
    7 
    +    The RTS API now exposes the `RUNTIME_TRACE_FLAG` type and
    8 
    +    the `getTraceFlags` and `setTraceFlags` functions that can be used to
    9 
    +    change the trace flags at runtime.
    10 
    +}

  • changelog.d/so_inline_is_a_predicate
    1 
    +section: ghc-lib
    2 
    +synopsis: Generalize the ``so_inline`` option of the simple optimizer to a predicate
    3 
    +          that selects the bindings to preserve.
    4 
    +
    5 
    +issues: #24386
    6 
    +mrs: !15988
    7 
    +
    8 
    +description: {
    9 
    +  The ``so_inline`` option of the simple optimizer was a boolean and now it is a
    10 
    +  predicate taking a binding ``Id`` and returning a boolean. ``const b`` has the
    11 
    +  same effect as formerly setting ``b``.
    12 
    +}

  • compiler/GHC/Core/SimpleOpt.hs
    ... ... @@ -108,6 +108,93 @@ unfolding-info to the scrutinee's Id.)
    108 108 
     * Bad bad bad: then the x in  case x of ... may be replaced with a version that has an unfolding.
    109 109
    110 110 
     See ticket #25790
    111 
    +
    112 
    +Note [Controlling inlining in the simple optimiser]
    113 
    +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    114 
    +Sometimes, plugins that analyse Core programs may want to prevent the
    115 
    +inlining of certain bindings. While they could avoid running the simple
    116 
    +optimiser at all, that would leave plenty of generated bindings that do not
    117 
    +have a direct correspondence to the source code.
    118 
    +
    119 
    +For example, consider the following Haskell code:
    120 
    +
    121 
    +    foo = z
    122 
    +      where
    123 
    +        z  = z1 + z2
    124 
    +        z1 = 42
    125 
    +        z2 = 1
    126 
    +
    127 
    +Before the simple optimizer runs, the Core programs is roughly:
    128 
    +
    129 
    +    foo =
    130 
    +      let
    131 
    +        foo_aIb =
    132 
    +          let
    133 
    +            z2
    134 
    +              = let
    135 
    +                  z2_aHG = 1
    136 
    +                 in
    137 
    +                  z2_aHG
    138 
    +           in
    139 
    +            let
    140 
    +              z1 =
    141 
    +                let
    142 
    +                  z1_aHR = 42
    143 
    +                 in
    144 
    +                  z1_aHR
    145 
    +             in
    146 
    +              let
    147 
    +                z =
    148 
    +                  let
    149 
    +                    z_aI5 = z1 + z2
    150 
    +                   in
    151 
    +                    z_aI5
    152 
    +               in
    153 
    +                z
    154 
    +      in
    155 
    +        foo_aIb
    156 
    +
    157 
    +After the simple optimizer runs, the Core program is:
    158 
    +
    159 
    +    foo = 42 + 1
    160 
    +
    161 
    +And the bindings for `z`, `z1`, and `z2` are all gone. If a plugin wanted to
    162 
    +analyse those bindings, it would have to deal with the unsimplified Core, but
    163 
    +cope with the generated bindings `z2_aHG`, `z1_aHR`, `z_aI5`, and `foo_aIb`,
    164 
    +all of which have no direct correspondence to the source code.
    165 
    +
    166 
    +Fortunately, a plugin can still improve the output by using the `so_inline`
    167 
    +field of `SimpleOpts`. The `so_inline` field is a /function/ of type
    168 
    +`(Id -> Bool)` that tells the simple optimiser whether or not to inline the `Id`.
    169 
    +The client of the GHC can thereby control precisely which bindings are inlined
    170 
    +and which are not. For instance,
    171 
    +
    172 
    +    simplOptPgm
    173 
    +      (defaultSimpleOpts { so_inline = (`notElem` ["z", "z1", "z2"]) })
    174 
    +      ...
    175 
    +
    176 
    +produces the following Core program:
    177 
    +
    178 
    +    foo =
    179 
    +      let
    180 
    +        z2 = 1
    181 
    +       in
    182 
    +        let
    183 
    +          z1 = 42
    184 
    +         in
    185 
    +          let
    186 
    +            z = z1 + z2
    187 
    +           in
    188 
    +            z
    189 
    +
    190 
    +which contains the bindings of interest and little else.
    191 
    +
    192 
    +For the specifics of how this affects a concrete plugin (Liquid Haskell), see
    193 
    +the discussion in https://gitlab.haskell.org/ghc/ghc/-/issues/24386
    194 
    +
    195 
    +In addition to supporting clients of the GHC API, there is another use of
    196 
    +`so_inline` mentioned in 'simpleOptExprNoInline'.
    197 
    +
    111 198 
     -}
    112 199
    113 200 
     -- | Simple optimiser options
    ... ... @@ -115,8 +202,11 @@ data SimpleOpts = SimpleOpts
    115 202 
        { so_uf_opts :: !UnfoldingOpts   -- ^ Unfolding options
    116 203 
        , so_co_opts :: !OptCoercionOpts -- ^ Coercion optimiser options
    117 204 
        , so_eta_red :: !Bool            -- ^ Eta reduction on?
    118 
    -   , so_inline :: !Bool             -- ^ False <=> do no inlining whatsoever,
    119 
    -                                    --    even for trivial or used-once things
    205 
    +   , so_inline :: !(Var -> Bool)    -- ^ False <=> do no inline the given
    206 
    +                                    --   binding whatsoever, even for trivial or
    207 
    +                                    --   used-once things
    208 
    +                                    --
    209 
    +                                    --   See Note [Controlling inlining in the simple optimiser]
    120 210 
        }
    121 211
    122 212 
     -- | Default options for the Simple optimiser.
    ... ... @@ -125,7 +215,7 @@ defaultSimpleOpts = SimpleOpts
    125 215 
        { so_uf_opts = defaultUnfoldingOpts
    126 216 
        , so_co_opts = OptCoercionOpts { optCoercionEnabled = False }
    127 217 
        , so_eta_red = False
    128 
    -   , so_inline  = True
    218 
    +   , so_inline  = const True
    129 219 
        }
    130 220
    131 221 
     simpleOptExpr :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    ... ... @@ -170,7 +260,7 @@ simpleOptExprNoInline :: HasDebugCallStack => SimpleOpts -> CoreExpr -> CoreExpr
    170 260 
     simpleOptExprNoInline opts expr
    171 261 
       = simple_opt_expr init_env expr
    172 262 
       where
    173 
    -    init_opts  = opts { so_inline = False }
    263 
    +    init_opts  = opts { so_inline = const False }
    174 264 
         init_env   = (emptyEnv init_opts) { soe_subst = init_subst }
    175 265 
         init_subst = mkEmptySubst (mkInScopeSet (exprFreeVars expr))
    176 266
    ... ... @@ -639,12 +729,12 @@ simple_bind_pair env@(SOE { soe_inl = inl_env, soe_subst = subst, soe_opts = opt
    639 729
    640 730 
         pre_inline_unconditionally :: Bool
    641 731 
         pre_inline_unconditionally
    642 
    -       | not (so_inline opts)     = False    -- Not if so_inline is False
    643 
    -       | isExportedId in_bndr     = False
    644 
    -       | stable_unf               = False
    645 
    -       | not active               = False    -- Note [Inline prag in simplOpt]
    646 
    -       | not (safe_to_inline occ) = False
    647 
    -       | otherwise                = True
    732 
    +       | not (so_inline opts in_bndr) = False    -- Not if so_inline is False
    733 
    +       | isExportedId in_bndr         = False
    734 
    +       | stable_unf                   = False
    735 
    +       | not active                   = False    -- Note [Inline prag in simplOpt]
    736 
    +       | not (safe_to_inline occ)     = False
    737 
    +       | otherwise                    = True
    648 738
    649 739 
             -- Unconditionally safe to inline
    650 740 
     safe_to_inline :: OccInfo -> Bool
    ... ... @@ -711,15 +801,15 @@ simple_out_bind_pair env@(SOE { soe_subst = subst, soe_opts = opts })
    711 801
    712 802 
         post_inline_unconditionally :: Bool
    713 803 
         post_inline_unconditionally
    714 
    -       | not (so_inline opts)  = False -- Not if so_inline is False
    715 
    -       | isExportedId in_bndr  = False -- Note [Exported Ids and trivial RHSs]
    716 
    -       | stable_unf            = False -- Note [Stable unfoldings and postInlineUnconditionally]
    717 
    -       | not active            = False --     in GHC.Core.Opt.Simplify.Utils
    718 
    -       | is_loop_breaker       = False -- If it's a loop-breaker of any kind, don't inline
    719 
    -                                       -- because it might be referred to "earlier"
    720 
    -       | exprIsTrivial out_rhs = True
    721 
    -       | coercible_hack        = True
    722 
    -       | otherwise             = False
    804 
    +       | not (so_inline opts in_bndr) = False -- Not if so_inline is False
    805 
    +       | isExportedId in_bndr         = False -- Note [Exported Ids and trivial RHSs]
    806 
    +       | stable_unf                   = False -- Note [Stable unfoldings and postInlineUnconditionally]
    807 
    +       | not active                   = False --     in GHC.Core.Opt.Simplify.Utils
    808 
    +       | is_loop_breaker              = False -- If it's a loop-breaker of any kind, don't inline
    809 
    +                                              -- because it might be referred to "earlier"
    810 
    +       | exprIsTrivial out_rhs        = True
    811 
    +       | coercible_hack               = True
    812 
    +       | otherwise                    = False
    723 813
    724 814 
         is_loop_breaker = isWeakLoopBreaker occ_info
    725 815

  • compiler/GHC/Driver/Config.hs
    ... ... @@ -26,7 +26,7 @@ initSimpleOpts dflags = SimpleOpts
    26 26 
        { so_uf_opts = unfoldingOpts dflags
    27 27 
        , so_co_opts = initOptCoercionOpts dflags
    28 28 
        , so_eta_red = gopt Opt_DoEtaReduction dflags
    29 
    -   , so_inline  = True
    29 
    +   , so_inline  = const True
    30 30 
        }
    31 31
    32 32 
     -- | Instruct the interpreter evaluation to break...

  • rts/RtsSymbols.c
    ... ... @@ -540,7 +540,12 @@ extern char **environ;
    540 540 
           SymI_HasProto(__word_encodeFloat)                                 \
    541 541 
           SymI_HasDataProto(stg_atomicallyzh)                                   \
    542 542 
           SymI_HasProto(barf)                                               \
    543 
    +      SymI_HasProto(startEventLogging)                                  \
    544 
    +      SymI_HasProto(endEventLogging)                                    \
    543 545 
           SymI_HasProto(flushEventLog)                                      \
    546 
    +      SymI_HasProto(flushEventLog)                                      \
    547 
    +      SymI_HasProto(getTraceFlag)                                       \
    548 
    +      SymI_HasProto(setTraceFlag)                                       \
    544 549 
           SymI_HasProto(deRefStablePtr)                                     \
    545 550 
           SymI_HasProto(debugBelch)                                         \
    546 551 
           SymI_HasProto(errorBelch)                                         \

  • rts/Trace.c
    ... ... @@ -29,14 +29,54 @@
    29 29 
     #include <unistd.h>
    30 30 
     #endif
    31 31
    32 
    -// events
    33 
    -uint8_t TRACE_sched;
    34 
    -uint8_t TRACE_gc;
    35 
    -uint8_t TRACE_nonmoving_gc;
    36 
    -uint8_t TRACE_spark_sampled;
    37 
    -uint8_t TRACE_spark_full;
    38 
    -uint8_t TRACE_user;
    39 
    -uint8_t TRACE_cap;
    32 
    +RUNTIME_TRACE_FLAG_CACHE RuntimeTraceFlagCache = {0};
    33 
    +
    34 
    +bool getTraceFlag(RUNTIME_TRACE_FLAG flag) {
    35 
    +  switch (flag) {
    36 
    +  case TRACE_SCHEDULER:
    37 
    +    return RuntimeTraceFlagCache.scheduler;
    38 
    +  case TRACE_GC:
    39 
    +    return RuntimeTraceFlagCache.gc;
    40 
    +  case TRACE_NONMOVING_GC:
    41 
    +    return RuntimeTraceFlagCache.nonmoving_gc;
    42 
    +  case TRACE_SPARK_SAMPLED:
    43 
    +    return RuntimeTraceFlagCache.spark_sampled;
    44 
    +  case TRACE_SPARK_FULL:
    45 
    +    return RuntimeTraceFlagCache.spark_full;
    46 
    +  case TRACE_USER:
    47 
    +    return RuntimeTraceFlagCache.user;
    48 
    +  case TRACE_CAP:
    49 
    +    return RuntimeTraceFlagCache.cap;
    50 
    +  default:
    51 
    +    return false;
    52 
    +  }
    53 
    +}
    54 
    +
    55 
    +void setTraceFlag(RUNTIME_TRACE_FLAG flag, bool value) {
    56 
    +  switch (flag) {
    57 
    +  case TRACE_SCHEDULER:
    58 
    +    RuntimeTraceFlagCache.scheduler = value;
    59 
    +    break;
    60 
    +  case TRACE_GC:
    61 
    +    RuntimeTraceFlagCache.gc = value;
    62 
    +    break;
    63 
    +  case TRACE_NONMOVING_GC:
    64 
    +    RuntimeTraceFlagCache.nonmoving_gc = value;
    65 
    +    break;
    66 
    +  case TRACE_SPARK_SAMPLED:
    67 
    +    RuntimeTraceFlagCache.spark_sampled = value;
    68 
    +    break;
    69 
    +  case TRACE_SPARK_FULL:
    70 
    +    RuntimeTraceFlagCache.spark_full = value;
    71 
    +    break;
    72 
    +  case TRACE_USER:
    73 
    +    RuntimeTraceFlagCache.user = value;
    74 
    +    break;
    75 
    +  case TRACE_CAP:
    76 
    +    RuntimeTraceFlagCache.cap = value;
    77 
    +    break;
    78 
    +  }
    79 
    +}
    40 80
    41 81 
     #if defined(THREADED_RTS)
    42 82 
     static Mutex trace_utx;
    ... ... @@ -51,43 +91,41 @@ static void traceCap_stderr(Capability *cap, char *msg, ...);
    51 91 
      --------------------------------------------------------------------------- */
    52 92
    53 93 
     /*
    54 
    - * Update the TRACE_* globals. Must be called whenever RtsFlags.TraceFlags is
    55 
    - * modified.
    94 
    + * Initialise the runtime trace flags from RtsFlags.TraceFlags.
    56 95 
      */
    57 
    -static void updateTraceFlagCache (void)
    58 
    -{
    59 
    -    // -Ds turns on scheduler tracing too
    60 
    -    TRACE_sched =
    61 
    -        RtsFlags.TraceFlags.scheduler ||
    62 
    -        RtsFlags.DebugFlags.scheduler;
    63 
    -
    64 
    -    // -Dg turns on gc tracing too
    65 
    -    TRACE_gc =
    66 
    -        RtsFlags.TraceFlags.gc ||
    67 
    -        RtsFlags.DebugFlags.gc ||
    68 
    -        RtsFlags.DebugFlags.scheduler;
    69 
    -
    70 
    -    TRACE_nonmoving_gc =
    71 
    -        RtsFlags.TraceFlags.nonmoving_gc;
    72 
    -
    73 
    -    TRACE_spark_sampled =
    74 
    -        RtsFlags.TraceFlags.sparks_sampled;
    75 
    -
    76 
    -    // -Dr turns on full spark tracing
    77 
    -    TRACE_spark_full =
    78 
    -        RtsFlags.TraceFlags.sparks_full ||
    79 
    -        RtsFlags.DebugFlags.sparks;
    80 
    -
    81 
    -    TRACE_user =
    82 
    -        RtsFlags.TraceFlags.user;
    83 
    -
    84 
    -    // We trace cap events if we're tracing anything else
    85 
    -    TRACE_cap =
    86 
    -        TRACE_sched ||
    87 
    -        TRACE_gc ||
    88 
    -        TRACE_spark_sampled ||
    89 
    -        TRACE_spark_full ||
    90 
    -        TRACE_user;
    96 
    +static void updateTraceFlagCache(void) {
    97 
    +  // -Ds turns on scheduler tracing too
    98 
    +  RuntimeTraceFlagCache.scheduler =
    99 
    +    RtsFlags.TraceFlags.scheduler ||
    100 
    +    RtsFlags.DebugFlags.scheduler;
    101 
    +
    102 
    +  // -Dg turns on gc tracing too
    103 
    +  RuntimeTraceFlagCache.gc =
    104 
    +    RtsFlags.TraceFlags.gc ||
    105 
    +    RtsFlags.DebugFlags.gc ||
    106 
    +    RtsFlags.DebugFlags.scheduler;
    107 
    +
    108 
    +  RuntimeTraceFlagCache.nonmoving_gc =
    109 
    +    RtsFlags.TraceFlags.nonmoving_gc;
    110 
    +
    111 
    +  RuntimeTraceFlagCache.spark_sampled =
    112 
    +    RtsFlags.TraceFlags.sparks_sampled;
    113 
    +
    114 
    +  // -Dr turns on full spark tracing
    115 
    +  RuntimeTraceFlagCache.spark_full =
    116 
    +      RtsFlags.TraceFlags.sparks_full ||
    117 
    +      RtsFlags.DebugFlags.sparks;
    118 
    +
    119 
    +  RuntimeTraceFlagCache.user =
    120 
    +    RtsFlags.TraceFlags.user;
    121 
    +
    122 
    +  // We trace cap events if we're tracing anything else
    123 
    +  RuntimeTraceFlagCache.cap =
    124 
    +    TRACE_sched ||
    125 
    +    TRACE_gc ||
    126 
    +    TRACE_spark_sampled ||
    127 
    +    TRACE_spark_full ||
    128 
    +    TRACE_user;
    91 129 
     }
    92 130
    93 131 
     void initTracing (void)
    ... ... @@ -880,59 +918,65 @@ void traceThreadLabel_(Capability *cap,
    880 918 
         }
    881 919 
     }
    882 920
    883 
    -void traceConcMarkBegin(void)
    921 
    +void traceNonmovingGcEvent_ (EventTypeNum tag)
    884 922 
     {
    885 
    -    if (eventlog_enabled)
    886 
    -        postEventNoCap(EVENT_CONC_MARK_BEGIN);
    923 
    +#if defined(DEBUG)
    924 
    +    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
    925 
    +        /* nothing - no string representation for nonmoving GC events  */
    926 
    +    } else
    927 
    +#endif
    928 
    +    {
    929 
    +        /* currently most non-moving GC events are nullary events */
    930 
    +        postEventNoCap(tag);
    931 
    +    }
    887 932 
     }
    888 933
    889 
    -void traceConcMarkEnd(StgWord32 marked_obj_count)
    934 
    +void traceConcMarkEnd_(StgWord32 marked_obj_count)
    890 935 
     {
    891 
    -    if (eventlog_enabled)
    936 
    +#if defined(DEBUG)
    937 
    +    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
    938 
    +        /* nothing - no string representation for nonmoving GC events  */
    939 
    +    } else
    940 
    +#endif
    941 
    +    {
    892 942 
             postConcMarkEnd(marked_obj_count);
    943 
    +    }
    893 944 
     }
    894 945
    895 
    -void traceConcSyncBegin(void)
    896 
    -{
    897 
    -    if (eventlog_enabled)
    898 
    -        postEventNoCap(EVENT_CONC_SYNC_BEGIN);
    899 
    -}
    900 
    -
    901 
    -void traceConcSyncEnd(void)
    902 
    -{
    903 
    -    if (eventlog_enabled)
    904 
    -        postEventNoCap(EVENT_CONC_SYNC_END);
    905 
    -}
    906 
    -
    907 
    -void traceConcSweepBegin(void)
    908 
    -{
    909 
    -    if (eventlog_enabled)
    910 
    -        postEventNoCap(EVENT_CONC_SWEEP_BEGIN);
    911 
    -}
    912 
    -
    913 
    -void traceConcSweepEnd(void)
    914 
    -{
    915 
    -    if (eventlog_enabled)
    916 
    -        postEventNoCap(EVENT_CONC_SWEEP_END);
    917 
    -}
    918 
    -
    919 
    -void traceConcUpdRemSetFlush(Capability *cap)
    946 
    +void traceConcUpdRemSetFlush_(Capability *cap)
    920 947 
     {
    921 
    -    if (eventlog_enabled)
    948 
    +#if defined(DEBUG)
    949 
    +    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
    950 
    +        /* nothing - no string representation for nonmoving GC events  */
    951 
    +    } else
    952 
    +#endif
    953 
    +    {
    922 954 
             postConcUpdRemSetFlush(cap);
    955 
    +    }
    923 956 
     }
    924 957
    925 
    -void traceNonmovingHeapCensus(uint16_t blk_size,
    926 
    -                              const struct NonmovingAllocCensus *census)
    958 
    +void traceNonmovingHeapCensus_(uint16_t blk_size, const struct NonmovingAllocCensus *census)
    927 959 
     {
    928 
    -    if (eventlog_enabled && TRACE_nonmoving_gc)
    960 
    +#if defined(DEBUG)
    961 
    +    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
    962 
    +        /* nothing - no string representation for nonmoving GC events  */
    963 
    +    } else
    964 
    +#endif
    965 
    +    {
    929 966 
             postNonmovingHeapCensus(blk_size, census);
    967 
    +    }
    930 968 
     }
    931 969
    932 
    -void traceNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments)
    970 
    +void traceNonmovingPrunedSegments_(uint32_t pruned_segments, uint32_t free_segments)
    933 971 
     {
    934 
    -    if (eventlog_enabled && TRACE_nonmoving_gc)
    972 
    +#if defined(DEBUG)
    973 
    +    if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) {
    974 
    +        /* nothing - no string representation for nonmoving GC events  */
    975 
    +    } else
    976 
    +#endif
    977 
    +    {
    935 978 
             postNonmovingPrunedSegments(pruned_segments, free_segments);
    979 
    +    }
    936 980 
     }
    937 981
    938 982 
     void traceThreadStatus_ (StgTSO *tso USED_IF_DEBUG)

  • rts/Trace.h
    ... ... @@ -70,16 +70,35 @@ enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM,
    70 70 
     #define DEBUG_continuation RtsFlags.DebugFlags.continuation
    71 71 
     #define DEBUG_iomanager   RtsFlags.DebugFlags.iomanager
    72 72
    73 
    -// Event-enabled flags
    74 
    -// These semantically booleans but we use a dense packing to minimize their
    75 
    -// cache impact.
    76 
    -extern uint8_t TRACE_sched;
    77 
    -extern uint8_t TRACE_gc;
    78 
    -extern uint8_t TRACE_nonmoving_gc;
    79 
    -extern uint8_t TRACE_spark_sampled;
    80 
    -extern uint8_t TRACE_spark_full;
    81 
    -extern uint8_t TRACE_cap;
    82 
    -/* extern uint8_t TRACE_user; */  // only used in Trace.c
    73 
    +// These trace flags are shorthand for the members of the RuntimeTraceFlagCache
    74 
    +// struct. Within the RTS, these should be treated as read-only variables.
    75 
    +#define TRACE_sched         ((const bool)RuntimeTraceFlagCache.scheduler)
    76 
    +#define TRACE_gc            ((const bool)RuntimeTraceFlagCache.gc)
    77 
    +#define TRACE_nonmoving_gc  ((const bool)RuntimeTraceFlagCache.nonmoving_gc)
    78 
    +#define TRACE_spark_sampled ((const bool)RuntimeTraceFlagCache.spark_sampled)
    79 
    +#define TRACE_spark_full    ((const bool)RuntimeTraceFlagCache.spark_full)
    80 
    +#define TRACE_user          ((const bool)RuntimeTraceFlagCache.user)
    81 
    +#define TRACE_cap           ((const bool)RuntimeTraceFlagCache.cap)
    82 
    +
    83 
    +/*
    84 
    + * Runtime trace flags.
    85 
    + */
    86 
    +typedef struct {
    87 
    +  bool scheduler;
    88 
    +  bool gc;
    89 
    +  bool nonmoving_gc;
    90 
    +  bool spark_sampled;
    91 
    +  bool spark_full;
    92 
    +  bool user;
    93 
    +  bool cap;
    94 
    +} RUNTIME_TRACE_FLAG_CACHE;
    95 
    +
    96 
    +/*
    97 
    + * These flags should be used to determine whether or not some value should
    98 
    + * be traced at runtime, rather than the values in RtsFlags. These flags can
    99 
    + * be modified at runtime using setTraceFlag in `rts/EventLogWriter.h`.
    100 
    + */
    101 
    +extern RUNTIME_TRACE_FLAG_CACHE RuntimeTraceFlagCache;
    83 102
    84 103 
     // -----------------------------------------------------------------------------
    85 104 
     // Posting events
    ... ... @@ -136,6 +155,52 @@ void traceGcEvent_ (Capability *cap, EventTypeNum tag);
    136 155
    137 156 
     void traceGcEventAtT_ (Capability *cap, StgWord64 ts, EventTypeNum tag);
    138 157
    158 
    +/*
    159 
    + * Record a nonmoving GC event.
    160 
    + */
    161 
    +#define traceConcMarkBegin()                                           \
    162 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    163 
    +        traceNonmovingGcEvent_(EVENT_CONC_MARK_BEGIN);                 \
    164 
    +    }
    165 
    +#define traceConcMarkEnd(marked_obj_count)                             \
    166 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    167 
    +        traceConcMarkEnd_(marked_obj_count);                           \
    168 
    +    }
    169 
    +#define traceConcSyncBegin()                                           \
    170 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    171 
    +        traceNonmovingGcEvent_(EVENT_CONC_SYNC_BEGIN);                 \
    172 
    +    }
    173 
    +#define traceConcSyncEnd()                                             \
    174 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    175 
    +        traceNonmovingGcEvent_(EVENT_CONC_SYNC_END);                   \
    176 
    +    }
    177 
    +#define traceConcSweepBegin()                                          \
    178 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    179 
    +        traceNonmovingGcEvent_(EVENT_CONC_SWEEP_BEGIN);                \
    180 
    +    }
    181 
    +#define traceConcSweepEnd()                                            \
    182 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    183 
    +        traceNonmovingGcEvent_(EVENT_CONC_SWEEP_END);                  \
    184 
    +    }
    185 
    +#define traceConcUpdRemSetFlush(cap)                                   \
    186 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    187 
    +        traceConcUpdRemSetFlush_(cap);                                 \
    188 
    +    }
    189 
    +#define traceNonmovingHeapCensus(blk_size, census)                     \
    190 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    191 
    +        traceNonmovingHeapCensus_(blk_size, census);                   \
    192 
    +    }
    193 
    +#define traceNonmovingPrunedSegments(pruned_segments, free_segments)   \
    194 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc)) {                            \
    195 
    +        traceNonmovingPrunedSegments_(pruned_segments, free_segments); \
    196 
    +    }
    197 
    +
    198 
    +void traceNonmovingGcEvent_ (EventTypeNum tag);
    199 
    +void traceConcMarkEnd_(StgWord32 marked_obj_count);
    200 
    +void traceConcUpdRemSetFlush_(Capability *cap);
    201 
    +void traceNonmovingHeapCensus_(uint16_t blk_size, const struct NonmovingAllocCensus *census);
    202 
    +void traceNonmovingPrunedSegments_(uint32_t pruned_segments, uint32_t free_segments);
    203 
    +
    139 204 
     /*
    140 205 
      * Record a heap event
    141 206 
      */
    ... ... @@ -321,17 +386,6 @@ void traceProfSampleCostCentre(Capability *cap,
    321 386 
     void traceProfBegin(void);
    322 387 
     #endif /* PROFILING */
    323 388
    324 
    -void traceConcMarkBegin(void);
    325 
    -void traceConcMarkEnd(StgWord32 marked_obj_count);
    326 
    -void traceConcSyncBegin(void);
    327 
    -void traceConcSyncEnd(void);
    328 
    -void traceConcSweepBegin(void);
    329 
    -void traceConcSweepEnd(void);
    330 
    -void traceConcUpdRemSetFlush(Capability *cap);
    331 
    -void traceNonmovingHeapCensus(uint16_t blk_size,
    332 
    -                              const struct NonmovingAllocCensus *census);
    333 
    -void traceNonmovingPrunedSegments(uint32_t pruned_segments, uint32_t free_segments);
    334 
    -
    335 389 
     void traceIPE(const InfoProvEnt *ipe);
    336 390 
     void flushTrace(void);
    337 391
    ... ... @@ -384,6 +438,7 @@ void flushTrace(void);
    384 438 
     #define traceConcSweepEnd() /* nothing */
    385 439 
     #define traceConcUpdRemSetFlush(cap) /* nothing */
    386 440 
     #define traceNonmovingHeapCensus(blk_size, census) /* nothing */
    441 
    +#define traceNonmovingPrunedSegments(pruned_segments, free_segments) /* nothing */
    387 442
    388 443 
     #define flushTrace() /* nothing */
    389 444

  • rts/include/rts/EventLogWriter.h
    ... ... @@ -78,3 +78,34 @@ void endEventLogging(void);
    78 78 
      * Flush the eventlog. cap can be NULL if one is not held.
    79 79 
      */
    80 80 
     void flushEventLog(Capability **cap);
    81 
    +
    82 
    +/*
    83 
    + * An enumeration for the runtime trace flags.
    84 
    + */
    85 
    +typedef enum {
    86 
    +  TRACE_SCHEDULER,
    87 
    +  TRACE_GC,
    88 
    +  TRACE_NONMOVING_GC,
    89 
    +  TRACE_SPARK_SAMPLED,
    90 
    +  TRACE_SPARK_FULL,
    91 
    +  TRACE_USER,
    92 
    +  TRACE_CAP,
    93 
    +} RUNTIME_TRACE_FLAG;
    94 
    +
    95 
    +/*
    96 
    + * Get the value of the given runtime trace flag.
    97 
    + *
    98 
    + * Warning: The trace flag cache is not thread-safe. After initialisation, the
    99 
    + * RTS never writes to these values, but concurrently using getTraceFlag and
    100 
    + * setTraceFlag for the same flag is a race condition.
    101 
    + */
    102 
    +bool getTraceFlag(RUNTIME_TRACE_FLAG flag);
    103 
    +
    104 
    +/*
    105 
    + * Set the value of the given runtime trace flag.
    106 
    + *
    107 
    + * Warning: The trace flag cache is not thread-safe. After initialisation, the
    108 
    + * RTS never writes to these values. However, inconsistent reads may lead to
    109 
    + * incorrect tracing for a short time after setting a trace flag.
    110 
    + */
    111 
    +void setTraceFlag(RUNTIME_TRACE_FLAG flag, bool value);

  • rts/posix/FdWakeup.c
    1 
    +/* -----------------------------------------------------------------------------
    2 
    + *
    3 
    + * (c) The GHC Team 2025
    4 
    + *
    5 
    + * Utilities for a simple fd-based cross-thread wakeup mechanism.
    6 
    + *
    7 
    + * This is used to provide a mechanism to wake a thread when it is blocked
    8 
    + * waiting on fds and timeouts. The mechanism works by including the read end
    9 
    + * fd into the set of fds the thread waits on, and when a wake up is needed,
    10 
    + * the write end fd is used.
    11 
    + *
    12 
    + * This is implemented using either eventfd() or pipe().
    13 
    + *
    14 
    + * Linux 2.6.22+ and FreeBSD 13+ support eventfd. It is a single fd with a
    15 
    + * 64bit counter. It uses fewer resources than a pipe (less memory and one
    16 
    + * rather than two fds), and is a tad faster (on the order of 5-10%). Using
    17 
    + * write() adds to the counter, while read() reads and resets it. Thus
    18 
    + * multiple writes are combined automatically into a single corresponding
    19 
    + * read.
    20 
    + *
    21 
    + * Otherwise we use a classic unix pipe.
    22 
    + *
    23 
    + * In both implementations, multiple sendFdWakeup notifcations (without
    24 
    + * interleaved collectFdWakeup) are combined to a single notification. This
    25 
    + * is automatic given the semantics of eventfd, while for pipe we implement
    26 
    + * it explicitly by draining the pipe in collectFdWakeup.
    27 
    + *
    28 
    + * -------------------------------------------------------------------------*/
    29 
    +
    30 
    +#include "rts/PosixSource.h"
    31 
    +#include "Rts.h"
    32 
    +
    33 
    +#include "FdWakeup.h"
    34 
    +
    35 
    +#include <fcntl.h>
    36 
    +#include <unistd.h>
    37 
    +
    38 
    +#ifdef HAVE_SYS_EVENTFD_H
    39 
    +#include <sys/eventfd.h>
    40 
    +#endif
    41 
    +
    42 
    +#if !defined(HAVE_EVENTFD) \
    43 
    + || (defined(HAVE_EVENTFD) && !(defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK)))
    44 
    +static void fcntl_CLOEXEC_NONBLOCK(int fd)
    45 
    +{
    46 
    +    int res1 = fcntl(fd, F_SETFD, FD_CLOEXEC);
    47 
    +    int res2 = fcntl(fd, F_SETFL, O_NONBLOCK);
    48 
    +    if (RTS_UNLIKELY(res1 < 0 || res2 < 0)) {
    49 
    +        sysErrorBelch("newFdWakeup fcntl()");
    50 
    +        stg_exit(EXIT_FAILURE);
    51 
    +    }
    52 
    +}
    53 
    +#endif
    54 
    +
    55 
    +void newFdWakeup(int *wakeup_fd_r, int *wakeup_fd_w)
    56 
    +{
    57 
    +#if defined(HAVE_EVENTFD)
    58 
    +    int wakeup_fd;
    59 
    +#if defined(EFD_CLOEXEC) && defined(EFD_NONBLOCK)
    60 
    +    wakeup_fd = eventfd(0, EFD_CLOEXEC | EFD_NONBLOCK);
    61 
    +#else
    62 
    +    wakeup_fd = eventfd(0, 0);
    63 
    +    if (wakeup_fd >= 0) fcntl_CLOEXEC_NONBLOCK(wakeup_fd);
    64 
    +#endif
    65 
    +    if (RTS_UNLIKELY(wakeup_fd < 0)) {
    66 
    +        sysErrorBelch("newFdWakeup eventfd()");
    67 
    +        stg_exit(EXIT_FAILURE);
    68 
    +    }
    69 
    +    /* eventfd uses the same fd for each end */
    70 
    +    *wakeup_fd_r = wakeup_fd;
    71 
    +    *wakeup_fd_w = wakeup_fd;
    72 
    +#else
    73 
    +    int pipefd[2];
    74 
    +    int res;
    75 
    +    res = pipe(pipefd);
    76 
    +    if (RTS_UNLIKELY(res < 0)) {
    77 
    +        sysErrorBelch("newFdWakeup pipe");
    78 
    +        stg_exit(EXIT_FAILURE);
    79 
    +    }
    80 
    +    fcntl_CLOEXEC_NONBLOCK(pipefd[0]);
    81 
    +    fcntl_CLOEXEC_NONBLOCK(pipefd[1]);
    82 
    +    *wakeup_fd_r = pipefd[0]; /* read end */
    83 
    +    *wakeup_fd_w = pipefd[1]; /* write end */
    84 
    +#endif
    85 
    +}
    86 
    +
    87 
    +void closeFdWakeup(int wakeup_fd_r, int wakeup_fd_w)
    88 
    +{
    89 
    +#if defined(HAVE_EVENTFD)
    90 
    +    ASSERT(wakeup_fd_r == wakeup_fd_w);
    91 
    +    close(wakeup_fd_r);
    92 
    +#else
    93 
    +    ASSERT(wakeup_fd_r != wakeup_fd_w);
    94 
    +    close(wakeup_fd_r);
    95 
    +    close(wakeup_fd_w);
    96 
    +#endif
    97 
    +}
    98 
    +
    99 
    +/* This is safe to use from a signal handler. Using write() to a pipe
    100 
    + * or eventfd is fine. */
    101 
    +void sendFdWakeup(int wakeup_fd_w)
    102 
    +{
    103 
    +    int res;
    104 
    +#if defined(HAVE_EVENTFD)
    105 
    +    uint64_t val = 1;
    106 
    +    res = write(wakeup_fd_w, &val, 8);
    107 
    +#else
    108 
    +    unsigned char buf = 1;
    109 
    +    res = write(wakeup_fd_w, &buf, 1);
    110 
    +#endif
    111 
    +    if (RTS_UNLIKELY(res < 0)) {
    112 
    +        /* Unlikely the pipe buffer will fill, but it would not be an error. */
    113 
    +        if (errno == EAGAIN) return;
    114 
    +        sysErrorBelch("sendFdWakeup write");
    115 
    +        stg_exit(EXIT_FAILURE);
    116 
    +    }
    117 
    +}
    118 
    +
    119 
    +void collectFdWakeup(int wakeup_fd_r)
    120 
    +{
    121 
    +    int res;
    122 
    +#if defined(HAVE_EVENTFD)
    123 
    +    uint64_t buf;
    124 
    +    /* eventfd combines events into one counter, so a single read is enough */
    125 
    +    res = read(wakeup_fd_r, &buf, 8);
    126 
    +#else
    127 
    +    /* Drain the pipe buffer. Multiple wakeup notifications could
    128 
    +     * have been sent before we have a chance to collect them.
    129 
    +     */
    130 
    +    uint64_t buf;
    131 
    +    do {
    132 
    +        res = read(wakeup_fd_r, &buf, 8);
    133 
    +    } while (res == 8);
    134 
    +#endif
    135 
    +    if (RTS_UNLIKELY(res < 0)) {
    136 
    +        /* After the first pipe read, it could block */
    137 
    +        if (errno == EAGAIN) return;
    138 
    +        sysErrorBelch("collectFdWakeup read");
    139 
    +        stg_exit(EXIT_FAILURE);
    140 
    +    }
    141 
    +}

  • rts/posix/FdWakeup.h
    1 
    +/* -----------------------------------------------------------------------------
    2 
    + *
    3 
    + * (c) The GHC Team 2025
    4 
    + *
    5 
    + * Utilities for a simple fd-based cross-thread wakeup mechanism.
    6 
    + *
    7 
    + * It provides a mechanism for a thread that block on fds to add a simple
    8 
    + * wakeup/notification feature.
    9 
    + *
    10 
    + * Start with newFdWakeup, and pass the fd_r to the thread that needs the
    11 
    + * wakeup feature. The thread that needs to be woken should include the fd_r
    12 
    + * into the set of fds that the thread waits on (e.g. using poll or similar).
    13 
    + * If this fd becomes ready for read, the thread must call collectFdWakeup,
    14 
    + * and when a wake up is needed, the write end fd is used. In any other thread
    15 
    + * (or in a signal handler), call sendFdWakeup(fd_w) to (asynchronously) cause
    16 
    + * the wakeup.
    17 
    + *
    18 
    + * There is no message payload. Multiple wakeups may be combined (if they're
    19 
    + * sent multiple times before the notified thread can wake and call
    20 
    + * collectFdWakeup).
    21 
    + *
    22 
    + * The implementation uses pipe() or eventfd() on supported OSs.
    23 
    + *
    24 
    + * Prototypes for functions in FdWakeup.c
    25 
    + *
    26 
    + * -------------------------------------------------------------------------*/
    27 
    +
    28 
    +#pragma once
    29 
    +
    30 
    +#include "BeginPrivate.h"
    31 
    +
    32 
    +void newFdWakeup(int *fd_r, int *fd_w);
    33 
    +void closeFdWakeup(int fd_r, int fd_w);
    34 
    +
    35 
    +/* This is safe to use from a signal handler */
    36 
    +void sendFdWakeup(int fd_w);
    37 
    +void collectFdWakeup(int fd_r);
    38 
    +
    39 
    +#include "EndPrivate.h"
    40 
    +

  • rts/posix/Ticker.c
    1 1 
     /* -----------------------------------------------------------------------------
    2 2 
      *
    3 
    - * (c) The GHC Team, 1995-2007
    3 
    + * (c) The GHC Team, 1995-2026
    4 4 
      *
    5 
    - * Posix implementation(s) of the interval timer for profiling and pre-emptive
    6 
    - * scheduling.
    5 
    + * The posix implementation of the interval timer, used for pre-emptive
    6 
    + * scheduling of Haskell threads, and for sample based profiling.
    7 
    + *
    8 
    + * This file defines the "ticker": the platform-specific service to install and
    9 
    + * run the timer. See rts/Timer.c for the platform-dependent view of interval
    10 
    + * timing.
    7 11 
      *
    8 12 
      * ---------------------------------------------------------------------------*/
    9 13
    10 
    -/* The interval timer is used for profiling and for context switching.
    11 
    - * This file defines the platform-specific services to install and run the
    12 
    - * timers, and we call this the ticker. See rts/Timer.c for the
    13 
    - * platform-dependent view of interval timing.
    14 
    +/* This implementation uses a posix thread which repeatedly blocks on a timeout
    15 
    + * using either the ppoll() or select() API. This lets it also block on a file
    16 
    + * descriptor for early wakeup.
    17 
    + *
    18 
    + * The design uses a simple relative time delay with no catchup. That is, time
    19 
    + * spent by the ticker thread itself (e.g. flushing eventlog buffers) is not
    20 
    + * accounted for, and the next tick is delayed by that much (modulo wakeup
    21 
    + * jitter). This is probably the right thing to do: generally in realtime
    22 
    + * systems one does not want to try to catch up when behind, since that tends
    23 
    + * towards oversubscribing resources. Graceful degredation is usually
    24 
    + * preferable.
    25 
    + *
    26 
    + * Experimental results (on Linux 6.18 on x86-64) to measure the typical
    27 
    + * difference between the requested wakeup time and actual wakeup time for
    28 
    + * different delay intervals:
    29 
    + *
    30 
    + *  interval   typical actual wakeup time after due time
    31 
    + *   10000us   340 -- 400us      (this is the default interval)
    32 
    + *    1000us    55 -- 100us
    33 
    + *     100us    55us
    34 
    + *      10us    55us
    35 
    + *
    36 
    + * While there's quite a bit of variance to these numbers, the results do not
    37 
    + * vary significantly between using select, ppoll or nanosleep.
    38 
    + *
    39 
    + * On Linux at least, for longer delays the kernel allows itself lower wakeup
    40 
    + * accuracy (which allows it to save power by coalescing multiple wakeups).
    41 
    + * Similarly, the reason for 55us on the low end is that the default thread
    42 
    + * timer slack on Linux is 50us, and context switch time accounts for the
    43 
    + * remainder.
    44 
    + *
    45 
    + * In conclusion, on Linux at least, the accuracy is fine, both for the
    46 
    + * default interval (10ms, 10000us) and for shorter intervals used during
    47 
    + * profiling.
    14 48 
      *
    15 49 
      * Historically we had ticker implementations using signals. This was always a
    16 
    - * rather shakey thing to do but we had few alternatives.
    50 
    + * rather shakey thing to do but we originally had few alternatives.
    17 51 
      * - One problem with using signals is that there are severe limits on what
    18 52 
      *   code can be called from signal handlers. In particular it's not possible
    19 53 
      *   to take locks in a signal handler contex. This was enough for contex
    ... ... @@ -23,17 +57,245 @@
    23 57 
      *   calls (#10840) or can be overwritten by user code.
    24 58 
      */
    25 59
    26 
    -/* Select a ticker implementation to use:
    27 
    - *
    28 
    - * On modern Linux, FreeBSD and NetBSD we can use timerfd_create and a thread
    29 
    - * that waits on it using poll. Linux has had timerfd since version 2.6.25.
    30 
    - * NetBSD has had timerfd since version 10, and FreeBSD since version 15.
    31 
    - *
    32 
    - * For older version of linux/bsd without timerfd, and for all other posix
    33 
    - * platforms, we use the implementation using posix pthreads and nanosleep().
    60 
    +#include "rts/PosixSource.h"
    61 
    +#include "Rts.h"
    62 
    +
    63 
    +#include "Ticker.h"
    64 
    +#include "RtsUtils.h"
    65 
    +#include "Proftimer.h"
    66 
    +#include "Schedule.h"
    67 
    +#include "posix/Clock.h"
    68 
    +#include "posix/FdWakeup.h"
    69 
    +
    70 
    +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
    71 
    +/* We prefer the ppoll() function if available since it allows sanely waiting
    72 
    + * on a single fd with precise timeouts (nanosecond precision). It is not in
    73 
    + * the posix standard however and some platforms (notably glibc and freebsd)
    74 
    + * need special CPP defines to make it available:
    75 
    + */
    76 
    +#define _GNU_SOURCE 1
    77 
    +#define __BSD_VISIBLE 1
    78 
    +#include <signal.h>
    79 
    +#include <poll.h>
    80 
    +#else
    81 
    +/* Otherwise we use the classic select(), which does have microsecond
    82 
    + * precision, but requires we build three whole 1024 bit (128 byte) fd sets
    83 
    + * just to wait on one fd.
    34 84 
      */
    35 
    -#if defined(HAVE_SYS_TIMERFD_H)
    36 
    -#include "ticker/TimerFd.c"
    85 
    +#include <sys/select.h>
    86 
    +#endif
    87 
    +
    88 
    +#include <time.h>
    89 
    +#if HAVE_SYS_TIME_H
    90 
    +# include <sys/time.h>
    91 
    +#endif
    92 
    +
    93 
    +#if defined(HAVE_SIGNAL_H)
    94 
    +# include <signal.h>
    95 
    +#endif
    96 
    +
    97 
    +#include <string.h>
    98 
    +
    99 
    +#include <pthread.h>
    100 
    +#if defined(HAVE_PTHREAD_NP_H)
    101 
    +#include <pthread_np.h>
    102 
    +#endif
    103 
    +#include <unistd.h>
    104 
    +#include <fcntl.h>
    105 
    +
    106 
    +static Time itimer_interval = DEFAULT_TICK_INTERVAL;
    107 
    +
    108 
    +// Should we be firing ticks?
    109 
    +// Writers to this must hold the mutex below.
    110 
    +static bool stopped = false;
    111 
    +
    112 
    +// should the ticker thread exit?
    113 
    +// This can be set without holding the mutex.
    114 
    +static bool exited = true;
    115 
    +
    116 
    +// Signaled when we want to (re)start the timer
    117 
    +static Condition start_cond;
    118 
    +static Mutex mutex;
    119 
    +static OSThreadId thread;
    120 
    +
    121 
    +// fds for interrupting the ticker
    122 
    +static int interruptfd_r = -1, interruptfd_w = -1;
    123 
    +
    124 
    +static void *itimer_thread_func(void *_handle_tick)
    125 
    +{
    126 
    +    TickProc handle_tick = _handle_tick;
    127 
    +
    128 
    +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
    129 
    +    struct pollfd pollfds[1];
    130 
    +
    131 
    +    pollfds[0].fd = interruptfd_r;
    132 
    +    pollfds[0].events = POLLIN;
    133 
    +
    134 
    +    struct timespec ts = { .tv_sec  = TimeToSeconds(itimer_interval)
    135 
    +                         , .tv_nsec = TimeToNS(itimer_interval) % 1000000000
    136 
    +                         };
    37 137 
     #else
    38 
    -#include "ticker/Pthread.c"
    138 
    +    fd_set selectfds;
    139 
    +    FD_ZERO(&selectfds);
    140 
    +    FD_SET(interruptfd_r, &selectfds);
    141 
    +
    142 
    +    struct timeval tv = { .tv_sec  = TimeToSeconds(itimer_interval)
    143 
    +                                     /* convert remainder time in nanoseconds
    144 
    +                                        to microseconds, rounding up: */
    145 
    +                        , .tv_usec = ((TimeToNS(itimer_interval) % 1000000000)
    146 
    +                                     + 999) / 1000
    147 
    +                        };
    148 
    +#endif
    149 
    +
    150 
    +    // Relaxed is sufficient: If we don't see that exited was set in one iteration we will
    151 
    +    // see it next time.
    152 
    +    while (!RELAXED_LOAD_ALWAYS(&exited)) {
    153 
    +
    154 
    +#if defined(HAVE_DECL_PPOLL) && HAVE_DECL_PPOLL == 1
    155 
    +        int nfds   = 1;
    156 
    +        int nready = ppoll(pollfds, nfds, &ts, NULL);
    157 
    +#else
    158 
    +        struct timeval tv_tmp = tv; // copy since select may change this value.
    159 
    +        int nfds   = interruptfd_r+1;
    160 
    +        int nready = select(nfds, &selectfds, NULL, NULL, &tv_tmp);
    161 
    +#endif
    162 
    +        // In either case (ppoll or select), the result nready is the number
    163 
    +        // of fds that are ready.
    164 
    +        if (RTS_LIKELY(nready == 0)) {
    165 
    +            // Timer expired, not interrupted, continue.
    166 
    +        } else if (nready > 0) {
    167 
    +            // We only monitor one fd (the interruptfd_r), so we know
    168 
    +            // it is that fd that is ready without any further checks.
    169 
    +            collectFdWakeup(interruptfd_r);
    170 
    +            // No further action needed, continue on to handling the final tick
    171 
    +            // and then stop.
    172 
    +
    173 
    +            // Note that we rely on sendFdWakeup and select/poll to provide the
    174 
    +            // happens-before relation. So if 'exited' was set before calling
    175 
    +            // sendFdWakeup, then we should be able to reliably read it after.
    176 
    +            // And thus reading 'exited' in the while loop guard is ok.
    177 
    +        } else {
    178 
    +            // While the RTS attempts to mask signals, some foreign libraries
    179 
    +            // that rely on signal delivery may unmask them. Consequently we
    180 
    +            // may see EINTR. See #24610.
    181 
    +            if (errno != EINTR) {
    182 
    +                sysErrorBelch("Ticker: poll failed: %s", strerror(errno));
    183 
    +            }
    184 
    +        }
    185 
    +
    186 
    +        // first try a cheap test
    187 
    +        if (RELAXED_LOAD_ALWAYS(&stopped)) {
    188 
    +            OS_ACQUIRE_LOCK(&mutex);
    189 
    +            // should we really stop?
    190 
    +            if (stopped) {
    191 
    +                waitCondition(&start_cond, &mutex);
    192 
    +            }
    193 
    +            OS_RELEASE_LOCK(&mutex);
    194 
    +        } else {
    195 
    +            handle_tick(0);
    196 
    +        }
    197 
    +    }
    198 
    +
    199 
    +    return NULL;
    200 
    +}
    201 
    +
    202 
    +void
    203 
    +initTicker (Time interval, TickProc handle_tick)
    204 
    +{
    205 
    +    itimer_interval = interval;
    206 
    +    stopped = true;
    207 
    +    exited = false;
    208 
    +#if defined(HAVE_SIGNAL_H)
    209 
    +    sigset_t mask, omask;
    210 
    +    int sigret;
    211 
    +#endif
    212 
    +    int ret;
    213 
    +
    214 
    +    initCondition(&start_cond);
    215 
    +    initMutex(&mutex);
    216 
    +
    217 
    +    /* Open the interrupt fd synchronously.
    218 
    +     *
    219 
    +     * We used to do it in itimer_thread_func (i.e. in the timer thread) but it
    220 
    +     * meant that some user code could run before it and get confused by the
    221 
    +     * allocation of the timerfd.
    222 
    +     *
    223 
    +     * See hClose002 which unsafely closes a file descriptor twice expecting an
    224 
    +     * exception the second time: it sometimes failed when the second call to
    225 
    +     * "close" closed our own timerfd which inadvertently reused the same file
    226 
    +     * descriptor closed by the first call! (see #20618)
    227 
    +     */
    228 
    +
    229 
    +    if (interruptfd_r != -1) {
    230 
    +        // don't leak the old file descriptors after a fork (#25280)
    231 
    +        closeFdWakeup(interruptfd_r, interruptfd_w);
    232 
    +    }
    233 
    +    newFdWakeup(&interruptfd_r, &interruptfd_w);
    234 
    +
    235 
    +    /*
    236 
    +     * Create the thread with all blockable signals blocked, leaving signal
    237 
    +     * handling to the main and/or other threads.  This is especially useful in
    238 
    +     * the non-threaded runtime, where applications might expect sigprocmask(2)
    239 
    +     * to effectively block signals.
    240 
    +     */
    241 
    +#if defined(HAVE_SIGNAL_H)
    242 
    +    sigfillset(&mask);
    243 
    +    sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask);
    244 
    +#endif
    245 
    +    ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick);
    246 
    +#if defined(HAVE_SIGNAL_H)
    247 
    +    if (sigret == 0)
    248 
    +        pthread_sigmask(SIG_SETMASK, &omask, NULL);
    39 249 
     #endif
    250 
    +
    251 
    +    if (ret != 0) {
    252 
    +        barf("Ticker: Failed to spawn thread: %s", strerror(errno));
    253 
    +    }
    254 
    +}
    255 
    +
    256 
    +void
    257 
    +startTicker(void)
    258 
    +{
    259 
    +    OS_ACQUIRE_LOCK(&mutex);
    260 
    +    RELAXED_STORE(&stopped, false);
    261 
    +    signalCondition(&start_cond);
    262 
    +    OS_RELEASE_LOCK(&mutex);
    263 
    +}
    264 
    +
    265 
    +/* There may be at most one additional tick fired after a call to this */
    266 
    +void
    267 
    +stopTicker(void)
    268 
    +{
    269 
    +    OS_ACQUIRE_LOCK(&mutex);
    270 
    +    RELAXED_STORE(&stopped, true);
    271 
    +    OS_RELEASE_LOCK(&mutex);
    272 
    +}
    273 
    +
    274 
    +/* There may be at most one additional tick fired after a call to this */
    275 
    +void
    276 
    +exitTicker (bool wait)
    277 
    +{
    278 
    +    ASSERT(!SEQ_CST_LOAD(&exited));
    279 
    +    SEQ_CST_STORE(&exited, true);
    280 
    +    // ensure that ticker wakes up if stopped
    281 
    +    startTicker();
    282 
    +    sendFdWakeup(interruptfd_w);
    283 
    +
    284 
    +    // wait for ticker to terminate if necessary
    285 
    +    if (wait) {
    286 
    +        if (pthread_join(thread, NULL)) {
    287 
    +            sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
    288 
    +        }
    289 
    +        closeFdWakeup(interruptfd_r, interruptfd_w);
    290 
    +        closeMutex(&mutex);
    291 
    +        closeCondition(&start_cond);
    292 
    +    } else {
    293 
    +        pthread_detach(thread);
    294 
    +    }
    295 
    +}
    296 
    +
    297 
    +int
    298 
    +rtsTimerSignal(void)
    299 
    +{
    300 
    +    return SIGALRM;
    301 
    +}

  • rts/posix/ticker/Pthread.c deleted
    1 
    -/* -----------------------------------------------------------------------------
    2 
    - *
    3 
    - * (c) The GHC Team, 1995-2007
    4 
    - *
    5 
    - * Interval timer for profiling and pre-emptive scheduling.
    6 
    - *
    7 
    - * ---------------------------------------------------------------------------*/
    8 
    -
    9 
    -/*
    10 
    - * We use a realtime timer by default.  I found this much more
    11 
    - * reliable than a CPU timer:
    12 
    - *
    13 
    - * Experiments with different frequencies: using
    14 
    - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32,
    15 
    - *     1000us has  <1% impact on runtime
    16 
    - *      100us has  ~2% impact on runtime
    17 
    - *       10us has ~40% impact on runtime
    18 
    - *
    19 
    - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32,
    20 
    - *     I cannot get it to tick faster than 10ms (10000us)
    21 
    - *     which isn't great for profiling.
    22 
    - *
    23 
    - * In the threaded RTS, we can't tick in CPU time because the thread
    24 
    - * which has the virtual timer might be idle, so the tick would never
    25 
    - * fire.  Therefore we used to tick in realtime in the threaded RTS and
    26 
    - * in CPU time otherwise, but now we always tick in realtime, for
    27 
    - * several reasons:
    28 
    - *
    29 
    - *   - resolution (see above)
    30 
    - *   - consistency (-threaded is the same as normal)
    31 
    - *   - more consistency: Windows only has a realtime timer
    32 
    - *
    33 
    - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME,
    34 
    - * because the latter may jump around (NTP adjustments, leap seconds
    35 
    - * etc.).
    36 
    - */
    37 
    -
    38 
    -#include "rts/PosixSource.h"
    39 
    -#include "Rts.h"
    40 
    -
    41 
    -#include "Ticker.h"
    42 
    -#include "RtsUtils.h"
    43 
    -#include "Proftimer.h"
    44 
    -#include "Schedule.h"
    45 
    -#include "posix/Clock.h"
    46 
    -#include <poll.h>
    47 
    -
    48 
    -#include <time.h>
    49 
    -#if HAVE_SYS_TIME_H
    50 
    -# include <sys/time.h>
    51 
    -#endif
    52 
    -
    53 
    -#if defined(HAVE_SIGNAL_H)
    54 
    -# include <signal.h>
    55 
    -#endif
    56 
    -
    57 
    -#include <string.h>
    58 
    -
    59 
    -#include <pthread.h>
    60 
    -#if defined(HAVE_PTHREAD_NP_H)
    61 
    -#include <pthread_np.h>
    62 
    -#endif
    63 
    -#include <unistd.h>
    64 
    -#include <fcntl.h>
    65 
    -
    66 
    -/*
    67 
    - * TFD_CLOEXEC has been added in Linux 2.6.26.
    68 
    - * If it is not available, we use fcntl(F_SETFD).
    69 
    - */
    70 
    -#if !defined(TFD_CLOEXEC)
    71 
    -#define TFD_CLOEXEC 0
    72 
    -#endif
    73 
    -
    74 
    -static Time itimer_interval = DEFAULT_TICK_INTERVAL;
    75 
    -
    76 
    -// Should we be firing ticks?
    77 
    -// Writers to this must hold the mutex below.
    78 
    -static bool stopped = false;
    79 
    -
    80 
    -// should the ticker thread exit?
    81 
    -// This can be set without holding the mutex.
    82 
    -static bool exited = true;
    83 
    -
    84 
    -// Signaled when we want to (re)start the timer
    85 
    -static Condition start_cond;
    86 
    -static Mutex mutex;
    87 
    -static OSThreadId thread;
    88 
    -
    89 
    -static void *itimer_thread_func(void *_handle_tick)
    90 
    -{
    91 
    -    TickProc handle_tick = _handle_tick;
    92 
    -
    93 
    -    // Relaxed is sufficient: If we don't see that exited was set in one iteration we will
    94 
    -    // see it next time.
    95 
    -    while (!RELAXED_LOAD_ALWAYS(&exited)) {
    96 
    -        if (rtsSleep(itimer_interval) != 0) {
    97 
    -            sysErrorBelch("Ticker: sleep failed: %s", strerror(errno));
    98 
    -        }
    99 
    -
    100 
    -        // first try a cheap test
    101 
    -        if (RELAXED_LOAD_ALWAYS(&stopped)) {
    102 
    -            OS_ACQUIRE_LOCK(&mutex);
    103 
    -            // should we really stop?
    104 
    -            if (stopped) {
    105 
    -                waitCondition(&start_cond, &mutex);
    106 
    -            }
    107 
    -            OS_RELEASE_LOCK(&mutex);
    108 
    -        } else {
    109 
    -            handle_tick(0);
    110 
    -        }
    111 
    -    }
    112 
    -
    113 
    -    return NULL;
    114 
    -}
    115 
    -
    116 
    -void
    117 
    -initTicker (Time interval, TickProc handle_tick)
    118 
    -{
    119 
    -    itimer_interval = interval;
    120 
    -    stopped = true;
    121 
    -    exited = false;
    122 
    -#if defined(HAVE_SIGNAL_H)
    123 
    -    sigset_t mask, omask;
    124 
    -    int sigret;
    125 
    -#endif
    126 
    -    int ret;
    127 
    -
    128 
    -    initCondition(&start_cond);
    129 
    -    initMutex(&mutex);
    130 
    -
    131 
    -    /*
    132 
    -     * Create the thread with all blockable signals blocked, leaving signal
    133 
    -     * handling to the main and/or other threads.  This is especially useful in
    134 
    -     * the non-threaded runtime, where applications might expect sigprocmask(2)
    135 
    -     * to effectively block signals.
    136 
    -     */
    137 
    -#if defined(HAVE_SIGNAL_H)
    138 
    -    sigfillset(&mask);
    139 
    -    sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask);
    140 
    -#endif
    141 
    -    ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick);
    142 
    -#if defined(HAVE_SIGNAL_H)
    143 
    -    if (sigret == 0)
    144 
    -        pthread_sigmask(SIG_SETMASK, &omask, NULL);
    145 
    -#endif
    146 
    -
    147 
    -    if (ret != 0) {
    148 
    -        barf("Ticker: Failed to spawn thread: %s", strerror(errno));
    149 
    -    }
    150 
    -}
    151 
    -
    152 
    -void
    153 
    -startTicker(void)
    154 
    -{
    155 
    -    OS_ACQUIRE_LOCK(&mutex);
    156 
    -    RELAXED_STORE(&stopped, false);
    157 
    -    signalCondition(&start_cond);
    158 
    -    OS_RELEASE_LOCK(&mutex);
    159 
    -}
    160 
    -
    161 
    -/* There may be at most one additional tick fired after a call to this */
    162 
    -void
    163 
    -stopTicker(void)
    164 
    -{
    165 
    -    OS_ACQUIRE_LOCK(&mutex);
    166 
    -    RELAXED_STORE(&stopped, true);
    167 
    -    OS_RELEASE_LOCK(&mutex);
    168 
    -}
    169 
    -
    170 
    -/* There may be at most one additional tick fired after a call to this */
    171 
    -void
    172 
    -exitTicker (bool wait)
    173 
    -{
    174 
    -    ASSERT(!SEQ_CST_LOAD(&exited));
    175 
    -    SEQ_CST_STORE(&exited, true);
    176 
    -    // ensure that ticker wakes up if stopped
    177 
    -    startTicker();
    178 
    -
    179 
    -    // wait for ticker to terminate if necessary
    180 
    -    if (wait) {
    181 
    -        if (pthread_join(thread, NULL)) {
    182 
    -            sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
    183 
    -        }
    184 
    -        closeMutex(&mutex);
    185 
    -        closeCondition(&start_cond);
    186 
    -    } else {
    187 
    -        pthread_detach(thread);
    188 
    -    }
    189 
    -}
    190 
    -
    191 
    -int
    192 
    -rtsTimerSignal(void)
    193 
    -{
    194 
    -    return SIGALRM;
    195 
    -}

  • rts/posix/ticker/TimerFd.c deleted
    1 
    -/* -----------------------------------------------------------------------------
    2 
    - *
    3 
    - * (c) The GHC Team, 1995-2023
    4 
    - *
    5 
    - * Interval timer for profiling and pre-emptive scheduling.
    6 
    - *
    7 
    - * ---------------------------------------------------------------------------*/
    8 
    -
    9 
    -/*
    10 
    - * We use a realtime timer by default.  I found this much more
    11 
    - * reliable than a CPU timer:
    12 
    - *
    13 
    - * Experiments with different frequencies: using
    14 
    - * CLOCK_REALTIME/CLOCK_MONOTONIC on Linux 2.6.32,
    15 
    - *     1000us has  <1% impact on runtime
    16 
    - *      100us has  ~2% impact on runtime
    17 
    - *       10us has ~40% impact on runtime
    18 
    - *
    19 
    - * using CLOCK_PROCESS_CPUTIME_ID on Linux 2.6.32,
    20 
    - *     I cannot get it to tick faster than 10ms (10000us)
    21 
    - *     which isn't great for profiling.
    22 
    - *
    23 
    - * In the threaded RTS, we can't tick in CPU time because the thread
    24 
    - * which has the virtual timer might be idle, so the tick would never
    25 
    - * fire.  Therefore we used to tick in realtime in the threaded RTS and
    26 
    - * in CPU time otherwise, but now we always tick in realtime, for
    27 
    - * several reasons:
    28 
    - *
    29 
    - *   - resolution (see above)
    30 
    - *   - consistency (-threaded is the same as normal)
    31 
    - *   - more consistency: Windows only has a realtime timer
    32 
    - *
    33 
    - * Note we want to use CLOCK_MONOTONIC rather than CLOCK_REALTIME,
    34 
    - * because the latter may jump around (NTP adjustments, leap seconds
    35 
    - * etc.).
    36 
    - */
    37 
    -
    38 
    -#include "rts/PosixSource.h"
    39 
    -#include "Rts.h"
    40 
    -
    41 
    -#include "Ticker.h"
    42 
    -#include "RtsUtils.h"
    43 
    -#include "Proftimer.h"
    44 
    -#include "Schedule.h"
    45 
    -#include "posix/Clock.h"
    46 
    -#include <poll.h>
    47 
    -
    48 
    -#include <time.h>
    49 
    -#if HAVE_SYS_TIME_H
    50 
    -# include <sys/time.h>
    51 
    -#endif
    52 
    -
    53 
    -#if defined(HAVE_SIGNAL_H)
    54 
    -# include <signal.h>
    55 
    -#endif
    56 
    -
    57 
    -#include <string.h>
    58 
    -
    59 
    -#include <pthread.h>
    60 
    -#if defined(HAVE_PTHREAD_NP_H)
    61 
    -#include <pthread_np.h>
    62 
    -#endif
    63 
    -#include <unistd.h>
    64 
    -#include <fcntl.h>
    65 
    -
    66 
    -#include <sys/timerfd.h>
    67 
    -
    68 
    -
    69 
    -/*
    70 
    - * TFD_CLOEXEC has been added in Linux 2.6.26.
    71 
    - * If it is not available, we use fcntl(F_SETFD).
    72 
    - */
    73 
    -#if !defined(TFD_CLOEXEC)
    74 
    -#define TFD_CLOEXEC 0
    75 
    -#endif
    76 
    -
    77 
    -static Time itimer_interval = DEFAULT_TICK_INTERVAL;
    78 
    -
    79 
    -// Should we be firing ticks?
    80 
    -// Writers to this must hold the mutex below.
    81 
    -static bool stopped = false;
    82 
    -
    83 
    -// should the ticker thread exit?
    84 
    -// This can be set without holding the mutex.
    85 
    -static bool exited = true;
    86 
    -
    87 
    -// Signaled when we want to (re)start the timer
    88 
    -static Condition start_cond;
    89 
    -static Mutex mutex;
    90 
    -static OSThreadId thread;
    91 
    -
    92 
    -// file descriptor for the timer (Linux only)
    93 
    -static int timerfd = -1;
    94 
    -
    95 
    -// pipe for signaling exit
    96 
    -static int pipefds[2];
    97 
    -
    98 
    -static void *itimer_thread_func(void *_handle_tick)
    99 
    -{
    100 
    -    TickProc handle_tick = _handle_tick;
    101 
    -    uint64_t nticks;
    102 
    -    ssize_t r = 0;
    103 
    -    struct pollfd pollfds[2];
    104 
    -
    105 
    -    pollfds[0].fd = pipefds[0];
    106 
    -    pollfds[0].events = POLLIN;
    107 
    -    pollfds[1].fd = timerfd;
    108 
    -    pollfds[1].events = POLLIN;
    109 
    -
    110 
    -    // Relaxed is sufficient: If we don't see that exited was set in one iteration we will
    111 
    -    // see it next time.
    112 
    -    while (!RELAXED_LOAD_ALWAYS(&exited)) {
    113 
    -        if (poll(pollfds, 2, -1) == -1) {
    114 
    -            // While the RTS attempts to mask signals, some foreign libraries
    115 
    -            // may rely on signal delivery may unmask them. Consequently we may
    116 
    -            // see EINTR. See #24610.
    117 
    -            if (errno != EINTR) {
    118 
    -                sysErrorBelch("Ticker: poll failed: %s", strerror(errno));
    119 
    -            }
    120 
    -        }
    121 
    -
    122 
    -        // We check the pipe first, even though the timerfd may also have triggered.
    123 
    -        if (pollfds[0].revents & POLLIN) {
    124 
    -            // the pipe is ready for reading, the only possible reason is that we're exiting
    125 
    -            exited = true; // set this again to make sure even RELAXED_LOAD will read the proper value
    126 
    -            // no further action needed, skip ahead to handling the final tick and then stopping
    127 
    -        }
    128 
    -        else if (pollfds[1].revents & POLLIN) { // the timerfd is ready for reading
    129 
    -            r = read(timerfd, &nticks, sizeof(nticks)); // this should never block now
    130 
    -
    131 
    -            if ((r == 0) && (errno == 0)) {
    132 
    -               /* r == 0 is expected only for non-blocking fd (in which case
    133 
    -                * errno should be EAGAIN) but we use a blocking fd.
    134 
    -                *
    135 
    -                * Due to a kernel bug (cf https://lkml.org/lkml/2019/8/16/335)
    136 
    -                * on some platforms we could see r == 0 and errno == 0.
    137 
    -                */
    138 
    -               IF_DEBUG(scheduler, debugBelch("read(timerfd) returned 0 with errno=0. This is a known kernel bug. We just ignore it."));
    139 
    -            }
    140 
    -            else if (r != sizeof(nticks) && errno != EINTR) {
    141 
    -               barf("Ticker: read(timerfd) failed with %s and returned %zd", strerror(errno), r);
    142 
    -            }
    143 
    -        }
    144 
    -
    145 
    -        // first try a cheap test
    146 
    -        if (RELAXED_LOAD_ALWAYS(&stopped)) {
    147 
    -            OS_ACQUIRE_LOCK(&mutex);
    148 
    -            // should we really stop?
    149 
    -            if (stopped) {
    150 
    -                waitCondition(&start_cond, &mutex);
    151 
    -            }
    152 
    -            OS_RELEASE_LOCK(&mutex);
    153 
    -        } else {
    154 
    -            handle_tick(0);
    155 
    -        }
    156 
    -    }
    157 
    -
    158 
    -    close(timerfd);
    159 
    -    return NULL;
    160 
    -}
    161 
    -
    162 
    -void
    163 
    -initTicker (Time interval, TickProc handle_tick)
    164 
    -{
    165 
    -    itimer_interval = interval;
    166 
    -    stopped = true;
    167 
    -    exited = false;
    168 
    -#if defined(HAVE_SIGNAL_H)
    169 
    -    sigset_t mask, omask;
    170 
    -    int sigret;
    171 
    -#endif
    172 
    -    int ret;
    173 
    -
    174 
    -    initCondition(&start_cond);
    175 
    -    initMutex(&mutex);
    176 
    -
    177 
    -    /* Open the file descriptor for the timer synchronously.
    178 
    -     *
    179 
    -     * We used to do it in itimer_thread_func (i.e. in the timer thread) but it
    180 
    -     * meant that some user code could run before it and get confused by the
    181 
    -     * allocation of the timerfd.
    182 
    -     *
    183 
    -     * See hClose002 which unsafely closes a file descriptor twice expecting an
    184 
    -     * exception the second time: it sometimes failed when the second call to
    185 
    -     * "close" closed our own timerfd which inadvertently reused the same file
    186 
    -     * descriptor closed by the first call! (see #20618)
    187 
    -     */
    188 
    -    struct itimerspec it;
    189 
    -    it.it_value.tv_sec  = TimeToSeconds(itimer_interval);
    190 
    -    it.it_value.tv_nsec = TimeToNS(itimer_interval) % 1000000000;
    191 
    -    it.it_interval = it.it_value;
    192 
    -
    193 
    -    if (timerfd != -1) {
    194 
    -        // don't leak the old file descriptors after a fork (#25280)
    195 
    -        close(timerfd);
    196 
    -        close(pipefds[0]);
    197 
    -        close(pipefds[1]);
    198 
    -        timerfd = -1;
    199 
    -    }
    200 
    -
    201 
    -    timerfd = timerfd_create(CLOCK_MONOTONIC, TFD_CLOEXEC);
    202 
    -    if (timerfd == -1) {
    203 
    -        barf("timerfd_create: %s", strerror(errno));
    204 
    -    }
    205 
    -    if (!TFD_CLOEXEC) {
    206 
    -        fcntl(timerfd, F_SETFD, FD_CLOEXEC);
    207 
    -    }
    208 
    -    if (timerfd_settime(timerfd, 0, &it, NULL)) {
    209 
    -        barf("timerfd_settime: %s", strerror(errno));
    210 
    -    }
    211 
    -
    212 
    -    if (pipe(pipefds) < 0) {
    213 
    -        barf("pipe: %s", strerror(errno));
    214 
    -    }
    215 
    -
    216 
    -    /*
    217 
    -     * Create the thread with all blockable signals blocked, leaving signal
    218 
    -     * handling to the main and/or other threads.  This is especially useful in
    219 
    -     * the non-threaded runtime, where applications might expect sigprocmask(2)
    220 
    -     * to effectively block signals.
    221 
    -     */
    222 
    -#if defined(HAVE_SIGNAL_H)
    223 
    -    sigfillset(&mask);
    224 
    -    sigret = pthread_sigmask(SIG_SETMASK, &mask, &omask);
    225 
    -#endif
    226 
    -    ret = createAttachedOSThread(&thread, "ghc_ticker", itimer_thread_func, (void*)handle_tick);
    227 
    -#if defined(HAVE_SIGNAL_H)
    228 
    -    if (sigret == 0)
    229 
    -        pthread_sigmask(SIG_SETMASK, &omask, NULL);
    230 
    -#endif
    231 
    -
    232 
    -    if (ret != 0) {
    233 
    -        barf("Ticker: Failed to spawn thread: %s", strerror(errno));
    234 
    -    }
    235 
    -}
    236 
    -
    237 
    -void
    238 
    -startTicker(void)
    239 
    -{
    240 
    -    OS_ACQUIRE_LOCK(&mutex);
    241 
    -    RELAXED_STORE(&stopped, false);
    242 
    -    signalCondition(&start_cond);
    243 
    -    OS_RELEASE_LOCK(&mutex);
    244 
    -}
    245 
    -
    246 
    -/* There may be at most one additional tick fired after a call to this */
    247 
    -void
    248 
    -stopTicker(void)
    249 
    -{
    250 
    -    OS_ACQUIRE_LOCK(&mutex);
    251 
    -    RELAXED_STORE(&stopped, true);
    252 
    -    OS_RELEASE_LOCK(&mutex);
    253 
    -}
    254 
    -
    255 
    -/* There may be at most one additional tick fired after a call to this */
    256 
    -void
    257 
    -exitTicker (bool wait)
    258 
    -{
    259 
    -    ASSERT(!SEQ_CST_LOAD(&exited));
    260 
    -    SEQ_CST_STORE(&exited, true);
    261 
    -    // ensure that ticker wakes up if stopped
    262 
    -    startTicker();
    263 
    -
    264 
    -    // wait for ticker to terminate if necessary
    265 
    -    if (wait) {
    266 
    -        // write anything to the pipe to trigger poll() in the ticker thread
    267 
    -        if (write(pipefds[1], "stop", 5) < 0) {
    268 
    -            sysErrorBelch("Ticker: Failed to write to pipe: %s", strerror(errno));
    269 
    -        }
    270 
    -
    271 
    -        if (pthread_join(thread, NULL)) {
    272 
    -            sysErrorBelch("Ticker: Failed to join: %s", strerror(errno));
    273 
    -        }
    274 
    -
    275 
    -        // These need to happen AFTER the ticker thread has finished to prevent a race condition
    276 
    -        // where the ticker thread closes the read end of the pipe before we're done writing to it.
    277 
    -        close(pipefds[0]);
    278 
    -        close(pipefds[1]);
    279 
    -
    280 
    -        closeMutex(&mutex);
    281 
    -        closeCondition(&start_cond);
    282 
    -    } else {
    283 
    -        pthread_detach(thread);
    284 
    -    }
    285 
    -}
    286 
    -
    287 
    -int
    288 
    -rtsTimerSignal(void)
    289 
    -{
    290 
    -    return SIGALRM;
    291 
    -}

  • rts/rts.cabal
    ... ... @@ -582,11 +582,9 @@ library
    582 582 
                         posix/Ticker.c
    583 583 
                         posix/OSMem.c
    584 584 
                         posix/OSThreads.c
    585 
    +                    posix/FdWakeup.c
    585 586 
                         posix/Poll.c
    586 587 
                         posix/Select.c
    587 588 
                         posix/Signals.c
    588 589 
                         posix/Timeout.c
    589 590 
                         posix/TTY.c
    590 
    -                    -- ticker/*.c
    591 
    -                    -- We don't want to compile posix/ticker/*.c, these will be #included
    592 
    -                    -- from Ticker.c

  • rts/sm/NonMoving.c
    ... ... @@ -1339,7 +1339,7 @@ concurrent_marking:
    1339 1339 
             nonmovingPrintAllocatorCensus(!concurrent);
    1340 1340 
     #endif
    1341 1341 
     #if defined(TRACING)
    1342 
    -    if (RtsFlags.TraceFlags.nonmoving_gc)
    1342 
    +    if (RTS_UNLIKELY(TRACE_nonmoving_gc))
    1343 1343 
             nonmovingTraceAllocatorCensus();
    1344 1344 
     #endif
    1345 1345

  • testsuite/tests/ghc-api/T24386.hs
    1 
    +
    2 
    +-- This test checks that bindings are preserved when configuring the simple
    3 
    +-- optimizer to not inline bindings with names selected by a predicate.
    4 
    +--
    5 
    +-- This feature is important for the LiquidHaskell plugin, which relies on the
    6 
    +-- simple optimizer to make core programs easier to read, but needs to preserve
    7 
    +-- bindings that are relevant for verification.
    8 
    +--
    9 
    +-- See https://gitlab.haskell.org/ghc/ghc/-/issues/24386 for the full discussion.
    10 
    +--
    11 
    +
    12 
    +import           Control.Monad
    13 
    +import           Data.List (find)
    14 
    +import           Data.Time (getCurrentTime)
    15 
    +import GHC
    16 
    +import GHC.Core
    17 
    +import GHC.Core.SimpleOpt
    18 
    +import GHC.Data.StringBuffer
    19 
    +import GHC.Driver.Config
    20 
    +import GHC.Driver.DynFlags
    21 
    +import GHC.Driver.Env.Types
    22 
    +import GHC.Types.Name
    23 
    +import GHC.Unit.Module.ModGuts
    24 
    +import GHC.Unit.Types
    25 
    +import GHC.Utils.Error
    26 
    +import GHC.Utils.Outputable
    27 
    +
    28 
    +import System.Environment (getArgs)
    29 
    +
    30 
    +
    31 
    +main :: IO ()
    32 
    +main =
    33 
    +  testLocalBindingsDesugaring
    34 
    +
    35 
    +testLocalBindingsDesugaring :: IO ()
    36 
    +testLocalBindingsDesugaring = do
    37 
    +    let inputSource = unlines
    38 
    +          [ "module LocalBindingsDesugaring where"
    39 
    +          , "f :: ()"
    40 
    +          , "f = z"
    41 
    +          , "  where"
    42 
    +          , "    z = ()"
    43 
    +          ]
    44 
    +
    45 
    +        isExpectedDesugaring p = case findExpr "f" p of
    46 
    +          Just (Let (NonRec b _) _)
    47 
    +            -> isIdNamed "z" b
    48 
    +          _ -> False
    49 
    +
    50 
    +        isIdNamed name v = occNameString (occName v) == name
    51 
    +
    52 
    +    coreProgram <-
    53 
    +       compileToCore
    54 
    +         (not . isIdNamed "z")
    55 
    +         "LocalBindingsDesugaring"
    56 
    +         inputSource
    57 
    +    unless (isExpectedDesugaring coreProgram) $
    58 
    +      fail $ unlines $
    59 
    +        "Unexpected desugaring: No local binding for `z` found in the Core program."
    60 
    +        : map showPprQualified coreProgram
    61 
    +
    62 
    +-- | Find the Core expression bound to the given name.
    63 
    +findExpr :: String -> CoreProgram -> Maybe CoreExpr
    64 
    +findExpr _ [] =
    65 
    +  Nothing
    66 
    +findExpr name (p:ps) = case p of
    67 
    +  NonRec b e
    68 
    +    | occNameString (occName b) == name
    69 
    +    -> Just e
    70 
    +  Rec binds
    71 
    +    | Just (_, e) <- find (\(b, _e) -> occNameString (occName b) == name) binds
    72 
    +    -> Just e
    73 
    +  _ -> findExpr name ps
    74 
    +
    75 
    +showPprQualified :: Outputable a => a -> String
    76 
    +showPprQualified = showSDocQualified . ppr
    77 
    +
    78 
    +showSDocQualified :: SDoc -> String
    79 
    +showSDocQualified = renderWithContext ctx
    80 
    +  where
    81 
    +    ctx = defaultSDocContext { sdocStyle = cmdlineParserStyle }
    82 
    +
    83 
    +
    84 
    +
    85 
    +compileToCore :: (Id -> Bool) -> String -> String -> IO [CoreBind]
    86 
    +compileToCore keepBindings modName inputSource = do
    87 
    +    [libdir] <- getArgs
    88 
    +    now <- getCurrentTime
    89 
    +    runGhc (Just libdir) $ do
    90 
    +      df1 <- getSessionDynFlags
    91 
    +      GHC.setSessionDynFlags $ df1 { GHC.backend = GHC.bytecodeBackend }
    92 
    +      let target = Target {
    93 
    +                   targetId           = TargetFile (modName ++ ".hs") Nothing
    94 
    +                 , targetUnitId       = homeUnitId_ df1
    95 
    +                 , targetAllowObjCode = False
    96 
    +                 , targetContents     = Just (stringToStringBuffer inputSource, now)
    97 
    +                 }
    98 
    +      setTargets [target]
    99 
    +      void $ GHC.depanal [] False
    100 
    +
    101 
    +      dsMod <- getModSummary
    102 
    +                 (mkModule mainUnit (mkModuleName modName))
    103 
    +             >>= parseModule
    104 
    +             >>= typecheckModule NoTcMPlugins
    105 
    +             >>= desugarModule
    106 
    +      hsc_env <- getSession
    107 
    +      return $ mg_binds $ simpleOptimize keepBindings hsc_env $ dm_core_module dsMod
    108 
    +
    109 
    +-- Run the simple optimizer
    110 
    +simpleOptimize :: (Id -> Bool) -> GHC.HscEnv -> ModGuts -> ModGuts
    111 
    +simpleOptimize keepBindings hsc_env guts@(ModGuts
    112 
    +                               { mg_module  = mgmod
    113 
    +                               , mg_binds   = binds
    114 
    +                               , mg_rules   = rules
    115 
    +                               }) =
    116 
    +    let dflags = hsc_dflags hsc_env
    117 
    +        simpl_opts = (initSimpleOpts dflags) { so_inline = keepBindings }
    118 
    +        (binds2, rules2, _occ_anald_binds) =
    119 
    +          simpleOptPgm simpl_opts mgmod binds rules
    120 
    +      in guts
    121 
    +          { mg_binds = binds2
    122 
    +          , mg_rules = rules2
    123 
    +          }

  • testsuite/tests/ghc-api/all.T
    ... ... @@ -81,3 +81,4 @@ test('T26910', [ extra_run_opts(f'"{config.libdir}"')
    81 81 
     test('TypeMapStringLiteral', normal, compile_and_run, ['-package ghc'])
    82 82
    83 83 
     test('T25121_status', normal, compile_and_run, ['-package ghc'])
    84 
    +test('T24386', [extra_run_opts(f'"{config.libdir}"')], compile_and_run, ['-package ghc'])

  • testsuite/tests/interface-stability/base-exports.stdout-ws-32 deleted The diff for this file was not included because it is too large.

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