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

Commits:

18 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/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, [''])

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