Duncan Coutts pushed to branch wip/dcoutts/posix-ticker at Glasgow Haskell Compiler / GHC

Commits:

24 changed files:

Changes:

  • changelog.d/T27022
    1
    +section: compiler
    
    2
    +synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter
    
    3
    +description: The ``recover`` method in TemplateHaskell now behaves the same 
    
    4
    +  with the internal and external interpreter.
    
    5
    +  In the past, when an error was encountered in a computation in a ``recover`` block,
    
    6
    +  the external interpreter would discard any state changes from ``putQ``,
    
    7
    +  whereas the internal interpreter would not.
    
    8
    +  This was a long-standing error in the implementation of the external interpreter.
    
    9
    +  Both now keep state changes from ``putQ`` in ``recover`` blocks.
    
    10
    +mrs: !15994
    
    11
    +issues: #27022

  • 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
    +}

  • hadrian/src/Settings/Packages.hs
    ... ... @@ -322,6 +322,7 @@ rtsPackageArgs = package rts ? do
    322 322
               , Profiling `wayUnit` way          ? arg "-DPROFILING"
    
    323 323
               , Threaded  `wayUnit` way          ? arg "-DTHREADED_RTS"
    
    324 324
               , notM targetSupportsSMP           ? arg "-optc-DNOSMP"
    
    325
    +          , isWinHost                        ? arg "-optl-Wl,--disable-runtime-pseudo-reloc"
    
    325 326
     
    
    326 327
                 -- See Note [AutoApply.cmm for vectors] in genapply/Main.hs
    
    327 328
                 --
    

  • libraries/ghci/GHCi/TH.hs
    ... ... @@ -119,7 +119,7 @@ initQState :: Pipe -> QState
    119 119
     initQState p = QState M.empty Nothing p
    
    120 120
     
    
    121 121
     -- | The monad in which we run TH computations on the server
    
    122
    -newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) }
    
    122
    +newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a }
    
    123 123
     
    
    124 124
     -- | The exception thrown by "fail" in the GHCiQ monad
    
    125 125
     data GHCiQException = GHCiQException QState String
    
    ... ... @@ -128,52 +128,54 @@ data GHCiQException = GHCiQException QState String
    128 128
     instance Exception GHCiQException
    
    129 129
     
    
    130 130
     instance Functor GHCiQ where
    
    131
    -  fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s
    
    131
    +  fmap f (GHCiQ m) = GHCiQ $ fmap f . m
    
    132 132
     
    
    133 133
     instance Applicative GHCiQ where
    
    134 134
       f <*> a = GHCiQ $ \s ->
    
    135
    -    do (f',s')  <- runGHCiQ f s
    
    136
    -       (a',s'') <- runGHCiQ a s'
    
    137
    -       return (f' a', s'')
    
    138
    -  pure x = GHCiQ (\s -> return (x,s))
    
    135
    +    do f'  <- runGHCiQ f s
    
    136
    +       a' <- runGHCiQ a s
    
    137
    +       return $ f' a'
    
    138
    +  pure x = GHCiQ $ \_ -> return x
    
    139 139
     
    
    140 140
     instance Monad GHCiQ where
    
    141 141
       m >>= f = GHCiQ $ \s ->
    
    142
    -    do (m', s')  <- runGHCiQ m s
    
    143
    -       (a,  s'') <- runGHCiQ (f m') s'
    
    144
    -       return (a, s'')
    
    142
    +    do m'  <- runGHCiQ m s
    
    143
    +       a <- runGHCiQ (f m') s
    
    144
    +       return a
    
    145 145
     
    
    146 146
     instance MonadFail GHCiQ where
    
    147
    -  fail err  = GHCiQ $ \s -> throwIO (GHCiQException s err)
    
    147
    +  fail err  = GHCiQ $ \sRef -> readIORef sRef >>= \s -> throwIO (GHCiQException s err)
    
    148 148
     
    
    149 149
     getState :: GHCiQ QState
    
    150
    -getState = GHCiQ $ \s -> return (s,s)
    
    150
    +getState = GHCiQ $ \sRef -> readIORef sRef
    
    151 151
     
    
    152 152
     noLoc :: TH.Loc
    
    153 153
     noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0)
    
    154 154
     
    
    155 155
     -- | Send a 'THMessage' to GHC and return the result.
    
    156 156
     ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a
    
    157
    -ghcCmd m = GHCiQ $ \s -> do
    
    157
    +ghcCmd m = GHCiQ $ \sRef -> do
    
    158
    +  s <- readIORef sRef
    
    158 159
       r <- remoteTHCall (qsPipe s) m
    
    159 160
       case r of
    
    160 161
         THException str -> throwIO (GHCiQException s str)
    
    161
    -    THComplete res -> return (res, s)
    
    162
    +    THComplete res -> return res
    
    162 163
     
    
    163 164
     instance MonadIO GHCiQ where
    
    164
    -  liftIO m = GHCiQ $ \s -> fmap (,s) m
    
    165
    +  liftIO m = GHCiQ $ \_ -> m
    
    165 166
     
    
    166 167
     instance TH.Quasi GHCiQ where
    
    167 168
       qNewName str = ghcCmd (NewName str)
    
    168 169
       qReport isError msg = ghcCmd (Report isError msg)
    
    169 170
     
    
    170 171
       -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice
    
    171
    -  qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do
    
    172
    +  qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do
    
    173
    +    s <- readIORef sRef
    
    172 174
         remoteTHCall (qsPipe s) StartRecover
    
    173
    -    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s
    
    175
    +    e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef
    
    174 176
         remoteTHCall (qsPipe s) (EndRecover (isLeft e))
    
    175 177
         case e of
    
    176
    -      Left GHCiQException{} -> h s
    
    178
    +      Left GHCiQException{} -> h sRef
    
    177 179
           Right r -> return r
    
    178 180
       qLookupName isType occ = ghcCmd (LookupName isType occ)
    
    179 181
       qReify name = ghcCmd (Reify name)
    
    ... ... @@ -200,15 +202,16 @@ instance TH.Quasi GHCiQ where
    200 202
       qAddTempFile suffix = ghcCmd (AddTempFile suffix)
    
    201 203
       qAddTopDecls decls = ghcCmd (AddTopDecls decls)
    
    202 204
       qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp)
    
    203
    -  qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>=
    
    205
    +  qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>=
    
    204 206
                              ghcCmd . AddModFinalizer
    
    205 207
       qAddCorePlugin str = ghcCmd (AddCorePlugin str)
    
    206
    -  qGetQ = GHCiQ $ \s ->
    
    208
    +  qGetQ = do
    
    209
    +    s <- getState
    
    207 210
         let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a
    
    208 211
             lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m
    
    209
    -    in return (lookup (qsMap s), s)
    
    210
    -  qPutQ k = GHCiQ $ \s ->
    
    211
    -    return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
    
    212
    +    return $ lookup (qsMap s)
    
    213
    +  qPutQ k = GHCiQ $ \sRef ->
    
    214
    +    modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) })
    
    212 215
       qIsExtEnabled x = ghcCmd (IsExtEnabled x)
    
    213 216
       qExtsEnabled = ghcCmd ExtsEnabled
    
    214 217
       qPutDoc l s = ghcCmd (PutDoc l s)
    
    ... ... @@ -231,7 +234,8 @@ runModFinalizerRefs pipe rstate qrefs = do
    231 234
       qs <- mapM localRef qrefs
    
    232 235
       qstateref <- localRef rstate
    
    233 236
       qstate <- readIORef qstateref
    
    234
    -  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe }
    
    237
    +  qstate' <- newIORef $ qstate { qsPipe = pipe }
    
    238
    +  _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate'
    
    235 239
       return ()
    
    236 240
     
    
    237 241
     -- | The implementation of the 'RunTH' message
    
    ... ... @@ -267,8 +271,6 @@ runTHQ
    267 271
       -> IO ByteString
    
    268 272
     runTHQ pipe rstate mb_loc ghciq = do
    
    269 273
       qstateref <- localRef rstate
    
    270
    -  qstate <- readIORef qstateref
    
    271
    -  let st = qstate { qsLocation = mb_loc, qsPipe = pipe }
    
    272
    -  (r,new_state) <- runGHCiQ (TH.runQ ghciq) st
    
    273
    -  writeIORef qstateref new_state
    
    274
    +  modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe })
    
    275
    +  r <- runGHCiQ (TH.runQ ghciq) qstateref
    
    274 276
       return $! LB.toStrict (runPut (put r))

  • rts/IOManager.h
    ... ... @@ -21,6 +21,15 @@
    21 21
     
    
    22 22
     #include "sm/GC.h" // for evac_fn
    
    23 23
     
    
    24
    +#if defined(mingw32_HOST_OS)
    
    25
    +/* Global var (only on Windows) that is exported (hence before BeginPrivate.h)
    
    26
    + * to be shared with the I/O code in the base library to tell us which style
    
    27
    + * of I/O manager we are using: one that uses the Windows native API HANDLEs,
    
    28
    + * or one that uses Posix style fds.
    
    29
    + */
    
    30
    +extern bool rts_IOManagerIsWin32Native;
    
    31
    +#endif
    
    32
    +
    
    24 33
     #include "BeginPrivate.h"
    
    25 34
     
    
    26 35
     /* The ./configure gives us a set of CPP flags, one for each named I/O manager:
    
    ... ... @@ -160,14 +169,6 @@ typedef enum {
    160 169
     /* Global var to tell us which I/O manager impl we are using */
    
    161 170
     extern IOManagerType iomgr_type;
    
    162 171
     
    
    163
    -#if defined(mingw32_HOST_OS)
    
    164
    -/* Global var (only on Windows) that is exported to be shared with the I/O code
    
    165
    - * in the base library to tell us which style of I/O manager we are using: one
    
    166
    - * that uses the Windows native API HANDLEs, or one that uses Posix style fds.
    
    167
    - */
    
    168
    -extern bool rts_IOManagerIsWin32Native;
    
    169
    -#endif
    
    170
    -
    
    171 172
     
    
    172 173
     /* The CapIOManager is the per-capability data structure belonging to the I/O
    
    173 174
      * manager. It is defined in full in IOManagerInternals.h. The opaque forward
    

  • rts/Linker.c
    ... ... @@ -478,16 +478,7 @@ initLinker_ (int retain_cafs)
    478 478
         symhash = allocStrHashTable();
    
    479 479
     
    
    480 480
         /* populate the symbol table with stuff from the RTS */
    
    481
    -    IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));
    
    482
    -    for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {
    
    483
    -        IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
    
    484
    -        if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
    
    485
    -                                    symhash, sym->lbl, sym->addr,
    
    486
    -                                    sym->strength, sym->type, 0, NULL)) {
    
    487
    -            barf("ghciInsertSymbolTable failed");
    
    488
    -        }
    
    489
    -    }
    
    490
    -    IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));
    
    481
    +    initLinkerRtsSyms(symhash);
    
    491 482
     
    
    492 483
         /* Add extra symbols. rtsExtraSyms() is a weakly defined symbol in the rts,
    
    493 484
          * that can be overrided by linking in an object with a corresponding
    

  • rts/LinkerInternals.h
    ... ... @@ -502,4 +502,6 @@ ObjectCode* mkOc( ObjectType type, pathchar *path, char *image, int imageSize,
    502 502
     void initSegment(Segment *s, void *start, size_t size, SegmentProt prot, int n_sections);
    
    503 503
     void freeSegments(ObjectCode *oc);
    
    504 504
     
    
    505
    +void initLinkerRtsSyms(StrHashTable *symhash);
    
    506
    +
    
    505 507
     #include "EndPrivate.h"

  • rts/RtsSymbols.c
    ... ... @@ -9,6 +9,8 @@
    9 9
     #include "ghcplatform.h"
    
    10 10
     #include "Rts.h"
    
    11 11
     #include "RtsSymbols.h"
    
    12
    +#include "LinkerInternals.h"
    
    13
    +#include "PathUtils.h"
    
    12 14
     
    
    13 15
     #include "TopHandler.h"
    
    14 16
     #include "HsFFI.h"
    
    ... ... @@ -51,6 +53,20 @@ extern char **environ;
    51 53
     
    
    52 54
     /* -----------------------------------------------------------------------------
    
    53 55
      * Symbols to be inserted into the RTS symbol table.
    
    56
    + *
    
    57
    + * Note [Naming Scheme for Symbol Macros]
    
    58
    + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
    59
    + *
    
    60
    + * SymI_*: symbol is internal to the RTS. It resides in an object
    
    61
    + *         file/library that is linked into the RTS library (as a static
    
    62
    + *         archive or dynamic shared library).
    
    63
    + * SymE_*: symbol is external to the RTS library. It might be linked
    
    64
    + *         dynamically.
    
    65
    + *
    
    66
    + * Sym*_HasProto  : the symbol prototype is imported in an include file
    
    67
    + *                  or defined explicitly
    
    68
    + * Sym*_NeedsProto: the symbol is undefined and we add a dummy
    
    69
    + *                  default proto extern void sym(void);
    
    54 70
      */
    
    55 71
     
    
    56 72
     #define Maybe_Stable_Names      SymI_HasProto(stg_mkWeakzh)                   \
    
    ... ... @@ -162,7 +178,7 @@ extern char **environ;
    162 178
           SymI_HasProto(stg_asyncWritezh)                    \
    
    163 179
           SymI_HasProto(stg_asyncDoProczh)                   \
    
    164 180
           SymI_HasProto(rts_InstallConsoleEvent)             \
    
    165
    -      SymI_HasProto(rts_IOManagerIsWin32Native)          \
    
    181
    +      SymI_HasDataProto(rts_IOManagerIsWin32Native)          \
    
    166 182
           SymI_HasProto(rts_ConsoleHandlerDone)              \
    
    167 183
           SymI_NeedsProto(__mingw_module_is_dll)             \
    
    168 184
           RTS_WIN64_ONLY(SymI_NeedsProto(___chkstk_ms))      \
    
    ... ... @@ -524,7 +540,12 @@ extern char **environ;
    524 540
           SymI_HasProto(__word_encodeFloat)                                 \
    
    525 541
           SymI_HasDataProto(stg_atomicallyzh)                                   \
    
    526 542
           SymI_HasProto(barf)                                               \
    
    543
    +      SymI_HasProto(startEventLogging)                                  \
    
    544
    +      SymI_HasProto(endEventLogging)                                    \
    
    527 545
           SymI_HasProto(flushEventLog)                                      \
    
    546
    +      SymI_HasProto(flushEventLog)                                      \
    
    547
    +      SymI_HasProto(getTraceFlag)                                       \
    
    548
    +      SymI_HasProto(setTraceFlag)                                       \
    
    528 549
           SymI_HasProto(deRefStablePtr)                                     \
    
    529 550
           SymI_HasProto(debugBelch)                                         \
    
    530 551
           SymI_HasProto(errorBelch)                                         \
    
    ... ... @@ -914,7 +935,7 @@ extern char **environ;
    914 935
           SymI_HasProto(freeExecPage)                                       \
    
    915 936
           SymI_HasProto(getAllocations)                                     \
    
    916 937
           SymI_HasProto(revertCAFs)                                         \
    
    917
    -      SymI_HasProto(RtsFlags)                                           \
    
    938
    +      SymI_HasDataProto(RtsFlags)                                           \
    
    918 939
           SymI_NeedsDataProto(rts_breakpoint_io_action)                     \
    
    919 940
           SymI_NeedsDataProto(rts_stop_next_breakpoint)                     \
    
    920 941
           SymI_NeedsDataProto(rts_stop_on_exception)                        \
    
    ... ... @@ -925,9 +946,9 @@ extern char **environ;
    925 946
           SymI_NeedsProto(rts_enableStopAfterReturn)                        \
    
    926 947
           SymI_NeedsProto(rts_disableStopAfterReturn)                       \
    
    927 948
           SymI_HasProto(stopTimer)                                          \
    
    928
    -      SymI_HasProto(n_capabilities)                                     \
    
    929
    -      SymI_HasProto(max_n_capabilities)                                 \
    
    930
    -      SymI_HasProto(enabled_capabilities)                               \
    
    949
    +      SymI_HasDataProto(n_capabilities)                                     \
    
    950
    +      SymI_HasDataProto(max_n_capabilities)                                 \
    
    951
    +      SymI_HasDataProto(enabled_capabilities)                               \
    
    931 952
           SymI_HasDataProto(stg_traceEventzh)                                   \
    
    932 953
           SymI_HasDataProto(stg_traceMarkerzh)                                  \
    
    933 954
           SymI_HasDataProto(stg_traceBinaryEventzh)                             \
    
    ... ... @@ -1145,12 +1166,27 @@ extern char **environ;
    1145 1166
           SymI_HasProto(hs_word2float64)
    
    1146 1167
     
    
    1147 1168
     
    
    1148
    -/* entirely bogus claims about types of these symbols */
    
    1149
    -#define SymI_NeedsProto(vvv)  extern void vvv(void);
    
    1150
    -#define SymI_NeedsDataProto(vvv)  extern StgWord vvv[];
    
    1151
    -#define SymE_NeedsProto(vvv)  SymI_NeedsProto(vvv);
    
    1152
    -#define SymE_NeedsDataProto(vvv)  SymI_NeedsDataProto(vvv);
    
    1153
    -#define SymE_HasProto(vvv)    SymI_HasProto(vvv);
    
    1169
    +/* Declare prototypes for the symbols that need it, so we can refer
    
    1170
    + * to them in the rtsSyms table below.
    
    1171
    + *
    
    1172
    + * In particular, for the external ones (SymE_*) we use the dllimport attribute
    
    1173
    + * to indicate that (on Windows) they come from external DLLs. This attribute
    
    1174
    + * is ignored on other platforms.
    
    1175
    + *
    
    1176
    + * The claims about the types of these symbols are entirely bogus.
    
    1177
    + */
    
    1178
    +#if defined(mingw32_HOST_OS) && defined(DYNAMIC)
    
    1179
    +#define DLLIMPORT __attribute__((dllimport))
    
    1180
    +#else
    
    1181
    +#define DLLIMPORT /**/
    
    1182
    +#endif
    
    1183
    +
    
    1184
    +#define SymI_NeedsProto(vvv)      extern           void vvv(void);
    
    1185
    +#define SymI_NeedsDataProto(vvv)  extern           StgWord vvv[];
    
    1186
    +#define SymE_NeedsProto(vvv)      extern DLLIMPORT void vvv(void);
    
    1187
    +#define SymE_NeedsDataProto(vvv)  extern DLLIMPORT StgWord vvv[];
    
    1188
    +
    
    1189
    +#define SymE_HasProto(vvv) /**/
    
    1154 1190
     #define SymI_HasProto(vvv) /**/
    
    1155 1191
     #define SymI_HasDataProto(vvv) /**/
    
    1156 1192
     #define SymI_HasProto_redirect(vvv,xxx,strength,ty) /**/
    
    ... ... @@ -1179,6 +1215,8 @@ RTS_SYMBOLS_PRIM
    1179 1215
     #undef SymE_NeedsProto
    
    1180 1216
     #undef SymE_NeedsDataProto
    
    1181 1217
     
    
    1218
    +/* See Note [Naming Scheme for Symbol Macros] */
    
    1219
    +
    
    1182 1220
     #define SymI_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
    
    1183 1221
                         (void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_CODE },
    
    1184 1222
     #define SymI_HasDataProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \
    
    ... ... @@ -1199,7 +1237,16 @@ RTS_SYMBOLS_PRIM
    1199 1237
         { MAYBE_LEADING_UNDERSCORE_STR(#vvv),    \
    
    1200 1238
           (void*)(&(xxx)), strength, ty },
    
    1201 1239
     
    
    1202
    -RtsSymbolVal rtsSyms[] = {
    
    1240
    +
    
    1241
    +
    
    1242
    +/* Initialize (if not already initialized) and return an array of symbols with stuff from the RTS. */
    
    1243
    +void initLinkerRtsSyms (StrHashTable *symhash) {
    
    1244
    +    /* The address of data symbols with the dllimport attribute are not
    
    1245
    +     * compile-time constants and so cannot be used in constant initialisers.
    
    1246
    +     * For this reason, rtsSyms is a local variable within this function
    
    1247
    +     * rather than a global constant (as it was historically).
    
    1248
    +     */
    
    1249
    +    const RtsSymbolVal rtsSyms[] = {
    
    1203 1250
           RTS_SYMBOLS
    
    1204 1251
           RTS_RET_SYMBOLS
    
    1205 1252
           RTS_POSIX_ONLY_SYMBOLS
    
    ... ... @@ -1214,7 +1261,20 @@ RtsSymbolVal rtsSyms[] = {
    1214 1261
           RTS_SYMBOLS_PRIM
    
    1215 1262
           SymI_HasDataProto(nonmoving_write_barrier_enabled)
    
    1216 1263
           { 0, 0, STRENGTH_NORMAL, SYM_TYPE_CODE } /* sentinel */
    
    1217
    -};
    
    1264
    +    };
    
    1265
    +
    
    1266
    +    IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n"));
    
    1267
    +    for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) {
    
    1268
    +        IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr));
    
    1269
    +        if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"),
    
    1270
    +                                    symhash, sym->lbl, sym->addr,
    
    1271
    +                                    sym->strength, sym->type, 0, NULL)) {
    
    1272
    +            barf("ghciInsertSymbolTable failed");
    
    1273
    +        }
    
    1274
    +    }
    
    1275
    +    IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n"));
    
    1276
    +}
    
    1277
    +
    
    1218 1278
     
    
    1219 1279
     
    
    1220 1280
     // Note [Extra RTS symbols]
    

  • rts/RtsSymbols.h
    ... ... @@ -46,8 +46,6 @@ typedef struct _RtsSymbolVal {
    46 46
         SymType type;
    
    47 47
     } RtsSymbolVal;
    
    48 48
     
    
    49
    -extern RtsSymbolVal rtsSyms[];
    
    50
    -
    
    51 49
     extern RtsSymbolVal* __attribute__((weak)) rtsExtraSyms(void);
    
    52 50
     
    
    53 51
     /* See Note [_iob_func symbol].  */
    

  • 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/linker/Elf.c
    ... ... @@ -76,18 +76,6 @@
    76 76
      *
    
    77 77
      * See bug #781
    
    78 78
      * See thread http://www.haskell.org/pipermail/cvs-ghc/2007-September/038458.html
    
    79
    - *
    
    80
    - * Naming Scheme for Symbol Macros
    
    81
    - *
    
    82
    - * SymI_*: symbol is internal to the RTS. It resides in an object
    
    83
    - *         file/library that is statically.
    
    84
    - * SymE_*: symbol is external to the RTS library. It might be linked
    
    85
    - *         dynamically.
    
    86
    - *
    
    87
    - * Sym*_HasProto  : the symbol prototype is imported in an include file
    
    88
    - *                  or defined explicitly
    
    89
    - * Sym*_NeedsProto: the symbol is undefined and we add a dummy
    
    90
    - *                  default proto extern void sym(void);
    
    91 79
      */
    
    92 80
     #define X86_64_ELF_NONPIC_HACK (!RtsFlags.MiscFlags.linkerAlwaysPic)
    
    93 81
     
    

  • 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/interface-stability/base-exports.stdout-ws-32 deleted The diff for this file was not included because it is too large.
  • testsuite/tests/th/T27022.hs
    1
    +{-# LANGUAGE TemplateHaskell #-}
    
    2
    +-- | This tests the behaviour of TH's recover method.
    
    3
    +-- It should behave the same in the internal and external interperter.
    
    4
    +-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not.
    
    5
    +module Main where
    
    6
    +
    
    7
    +import Language.Haskell.TH.Syntax
    
    8
    +main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops")  >> getQ @String >>= lift )

  • testsuite/tests/th/T27022.stdout
    1
    +Just "42"

  • testsuite/tests/th/all.T
    ... ... @@ -650,3 +650,4 @@ test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-un
    650 650
     test('T26099', normal, compile_fail, [''])
    
    651 651
     test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script'])
    
    652 652
     test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script'])
    
    653
    +test('T27022', normal, compile_and_run, [''])