Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: 5c4c3bf4 by Sylvain Henry at 2026-05-02T03:39:28-04:00 testsuite: fix flaky foundation Divisible / mulIntMayOflo# tests (#27222) Since the LCG was widened to 64 bits and the seed randomised per CI run (commit 2d30f7d3400 "Vendor mini-QuickCheck for testsuite"), two latent bugs in the foundation test surface stochastically: * The Divisible property `(x `div` y) * y + (x `mod` y) == x` raises ArithException(Overflow) when (a, b) = (minBound, -1) for fixed-width signed Integral types. Split testNumber/testDivisible into Bounded and unbounded variants and skip just that one pair, gated by `(minBound :: a) < 0` so unsigned types lose no coverage. * The `mulIntMayOflo#` test compared raw Int# bit-for-bit, but the primop is only specified to return 0/non-zero -- the exact non-zero indicator legitimately differs between backends and inlining choices. Add a dedicated `testPrimopMayOflo` helper that only compares zero / non-zero. Also fix the long-standing typo "Dividible" -> "Divisible" in identifiers. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com> - - - - - e242ce4f by Sylvain Henry at 2026-05-02T03:39:28-04:00 testsuite: catch and display exceptions in MiniQuickCheck Exceptions raised while evaluating a property are now caught and reported as a normal failure (with arguments and seed), instead of aborting the test. Co-Authored-By: Claude Opus 4.7 (1M context) <noreply@anthropic.com> - - - - - 3b75cccd by fendor at 2026-05-02T03:40:14-04:00 Fix name of Note [Structure of dep_boot_mods] - - - - - a179e30b by Duncan Coutts at 2026-05-05T09:34:15-04:00 Use __attribute__((dllimport)) for external RTS symbol declarations This is needed to be hygenic about DLL symbol imports and exports. The attribute is ignored on platforms other than Windows. Use of the attribute however means that external data symbols do not have a compile-time constant address (they are loaded using an indirection). This means we have to adjust the rtsSyms initial linker table so that it is a local constant in a function, rather than a global constant. We now define it within a function that pre-populates the symbol table with the RTS symbols. - - - - - fdd26b00 by Duncan Coutts at 2026-05-05T09:34:15-04:00 Fix the rts linker declarations for a few data symbols and ensure that the (windows only) rts_IOManagerIsWin32Native data symbol is marked as externally visible. - - - - - 1036f2ac by David Eichmann at 2026-05-05T09:34:15-04:00 Hadrian: Disable runtime pseudo relocations for RTS on windows hosts - - - - - 6414bc49 by Teo Camarasu at 2026-05-05T09:34:16-04:00 ghci/TH: refactor to use IORef QState This is a pure refactor and shouldn't modify semantics at all - - - - - bce22879 by Teo Camarasu at 2026-05-05T09:34:16-04:00 iserv: recover/getQ/putQ should behave same as internal interpreter The internal and external interpreter should behave the same when handling `recover`, the exeception recovery method of Q. In practice, they diverge. In case of failure, the internal interpreter only restores error message state to before the computation, wheras the external interperter restores error message state *and* the state of putQ/getQ. As far as I can tell this is a simple mistake in the implementation. Note [TH recover with -fexternal-interpreter] describes the correct behaviour but the implementation doesn't mirror this. This change restores the correct behaviour by keeping the effects of putQ in the erroring computation. This is a breaking change since it modifies the behaviour of programs that rely on recover ignoring putQ from failling computations when used with the external interpreter. Although I highly doubt anyone relies on this behaviour. This divergence was first introduced in d00c308633fe7d216d31a1087e00e63532d87d6d. As far as I can tell this was unintentional and tha commit was trying to solve a different bug. Resolves #27022 - - - - - 16 changed files: - + changelog.d/T27022 - compiler/GHC/Unit/Module/Deps.hs - hadrian/src/Settings/Packages.hs - libraries/ghci/GHCi/TH.hs - rts/IOManager.h - rts/Linker.c - rts/LinkerInternals.h - rts/RtsSymbols.c - rts/RtsSymbols.h - rts/linker/Elf.c - testsuite/tests/MiniQuickCheck.hs - testsuite/tests/linters/notes.stdout - testsuite/tests/numeric/should_run/foundation.hs - + testsuite/tests/th/T27022.hs - + testsuite/tests/th/T27022.stdout - testsuite/tests/th/all.T Changes: ===================================== changelog.d/T27022 ===================================== @@ -0,0 +1,11 @@ +section: compiler +synopsis: Fix a divergence in the interaction between ``recover`` and ``putQ`` between the internal and external interpreter +description: The ``recover`` method in TemplateHaskell now behaves the same + with the internal and external interpreter. + In the past, when an error was encountered in a computation in a ``recover`` block, + the external interpreter would discard any state changes from ``putQ``, + whereas the internal interpreter would not. + This was a long-standing error in the implementation of the external interpreter. + Both now keep state changes from ``putQ`` in ``recover`` blocks. +mrs: !15994 +issues: #27022 ===================================== compiler/GHC/Unit/Module/Deps.hs ===================================== @@ -96,7 +96,7 @@ data Dependencies = Deps , dep_boot_mods_ :: Set (UnitId, ModuleNameWithIsBoot) -- ^ All modules which have boot files below this one, and whether we -- should use the boot file or not. - -- This information is only used to populate the eps_is_boot field. + -- This information is only used to populate the 'eps_is_boot' field. -- See Note [Structure of dep_boot_mods] , dep_orphs_ :: [Module] @@ -605,7 +605,7 @@ hash of the module. The export hash is computed in `GHC.Iface.Recomp.addFingerpr -} {- -Note [Structure of dep_boot_deps] +Note [Structure of dep_boot_mods] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In `-c` mode we always need to know whether to load the normal or boot version of ===================================== hadrian/src/Settings/Packages.hs ===================================== @@ -322,6 +322,7 @@ rtsPackageArgs = package rts ? do , Profiling `wayUnit` way ? arg "-DPROFILING" , Threaded `wayUnit` way ? arg "-DTHREADED_RTS" , notM targetSupportsSMP ? arg "-optc-DNOSMP" + , isWinHost ? arg "-optl-Wl,--disable-runtime-pseudo-reloc" -- See Note [AutoApply.cmm for vectors] in genapply/Main.hs -- ===================================== libraries/ghci/GHCi/TH.hs ===================================== @@ -119,7 +119,7 @@ initQState :: Pipe -> QState initQState p = QState M.empty Nothing p -- | The monad in which we run TH computations on the server -newtype GHCiQ a = GHCiQ { runGHCiQ :: QState -> IO (a, QState) } +newtype GHCiQ a = GHCiQ { runGHCiQ :: IORef QState -> IO a } -- | The exception thrown by "fail" in the GHCiQ monad data GHCiQException = GHCiQException QState String @@ -128,52 +128,54 @@ data GHCiQException = GHCiQException QState String instance Exception GHCiQException instance Functor GHCiQ where - fmap f (GHCiQ s) = GHCiQ $ fmap (\(x,s') -> (f x,s')) . s + fmap f (GHCiQ m) = GHCiQ $ fmap f . m instance Applicative GHCiQ where f <*> a = GHCiQ $ \s -> - do (f',s') <- runGHCiQ f s - (a',s'') <- runGHCiQ a s' - return (f' a', s'') - pure x = GHCiQ (\s -> return (x,s)) + do f' <- runGHCiQ f s + a' <- runGHCiQ a s + return $ f' a' + pure x = GHCiQ $ \_ -> return x instance Monad GHCiQ where m >>= f = GHCiQ $ \s -> - do (m', s') <- runGHCiQ m s - (a, s'') <- runGHCiQ (f m') s' - return (a, s'') + do m' <- runGHCiQ m s + a <- runGHCiQ (f m') s + return a instance MonadFail GHCiQ where - fail err = GHCiQ $ \s -> throwIO (GHCiQException s err) + fail err = GHCiQ $ \sRef -> readIORef sRef >>= \s -> throwIO (GHCiQException s err) getState :: GHCiQ QState -getState = GHCiQ $ \s -> return (s,s) +getState = GHCiQ $ \sRef -> readIORef sRef noLoc :: TH.Loc noLoc = TH.Loc "<no file>" "<no package>" "<no module>" (0,0) (0,0) -- | Send a 'THMessage' to GHC and return the result. ghcCmd :: Binary a => THMessage (THResult a) -> GHCiQ a -ghcCmd m = GHCiQ $ \s -> do +ghcCmd m = GHCiQ $ \sRef -> do + s <- readIORef sRef r <- remoteTHCall (qsPipe s) m case r of THException str -> throwIO (GHCiQException s str) - THComplete res -> return (res, s) + THComplete res -> return res instance MonadIO GHCiQ where - liftIO m = GHCiQ $ \s -> fmap (,s) m + liftIO m = GHCiQ $ \_ -> m instance TH.Quasi GHCiQ where qNewName str = ghcCmd (NewName str) qReport isError msg = ghcCmd (Report isError msg) -- See Note [TH recover with -fexternal-interpreter] in GHC.Tc.Gen.Splice - qRecover (GHCiQ h) a = GHCiQ $ \s -> mask $ \unmask -> do + qRecover (GHCiQ h) a = GHCiQ $ \sRef -> mask $ \unmask -> do + s <- readIORef sRef remoteTHCall (qsPipe s) StartRecover - e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) s + e <- try $ unmask $ runGHCiQ (a <* ghcCmd FailIfErrs) sRef remoteTHCall (qsPipe s) (EndRecover (isLeft e)) case e of - Left GHCiQException{} -> h s + Left GHCiQException{} -> h sRef Right r -> return r qLookupName isType occ = ghcCmd (LookupName isType occ) qReify name = ghcCmd (Reify name) @@ -200,15 +202,16 @@ instance TH.Quasi GHCiQ where qAddTempFile suffix = ghcCmd (AddTempFile suffix) qAddTopDecls decls = ghcCmd (AddTopDecls decls) qAddForeignFilePath lang fp = ghcCmd (AddForeignFilePath lang fp) - qAddModFinalizer fin = GHCiQ (\s -> mkRemoteRef fin >>= return . (, s)) >>= + qAddModFinalizer fin = GHCiQ (\_ -> mkRemoteRef fin) >>= ghcCmd . AddModFinalizer qAddCorePlugin str = ghcCmd (AddCorePlugin str) - qGetQ = GHCiQ $ \s -> + qGetQ = do + s <- getState let lookup :: forall a. Typeable a => Map TypeRep Dynamic -> Maybe a lookup m = fromDynamic =<< M.lookup (typeOf (undefined::a)) m - in return (lookup (qsMap s), s) - qPutQ k = GHCiQ $ \s -> - return ((), s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) + return $ lookup (qsMap s) + qPutQ k = GHCiQ $ \sRef -> + modifyIORef' sRef (\s -> s { qsMap = M.insert (typeOf k) (toDyn k) (qsMap s) }) qIsExtEnabled x = ghcCmd (IsExtEnabled x) qExtsEnabled = ghcCmd ExtsEnabled qPutDoc l s = ghcCmd (PutDoc l s) @@ -231,7 +234,8 @@ runModFinalizerRefs pipe rstate qrefs = do qs <- mapM localRef qrefs qstateref <- localRef rstate qstate <- readIORef qstateref - _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate { qsPipe = pipe } + qstate' <- newIORef $ qstate { qsPipe = pipe } + _ <- runGHCiQ (TH.runQ $ sequence_ qs) qstate' return () -- | The implementation of the 'RunTH' message @@ -267,8 +271,6 @@ runTHQ -> IO ByteString runTHQ pipe rstate mb_loc ghciq = do qstateref <- localRef rstate - qstate <- readIORef qstateref - let st = qstate { qsLocation = mb_loc, qsPipe = pipe } - (r,new_state) <- runGHCiQ (TH.runQ ghciq) st - writeIORef qstateref new_state + modifyIORef' qstateref (\qstate -> qstate { qsLocation = mb_loc, qsPipe = pipe }) + r <- runGHCiQ (TH.runQ ghciq) qstateref return $! LB.toStrict (runPut (put r)) ===================================== rts/IOManager.h ===================================== @@ -21,6 +21,15 @@ #include "sm/GC.h" // for evac_fn +#if defined(mingw32_HOST_OS) +/* Global var (only on Windows) that is exported (hence before BeginPrivate.h) + * to be shared with the I/O code in the base library to tell us which style + * of I/O manager we are using: one that uses the Windows native API HANDLEs, + * or one that uses Posix style fds. + */ +extern bool rts_IOManagerIsWin32Native; +#endif + #include "BeginPrivate.h" /* The ./configure gives us a set of CPP flags, one for each named I/O manager: @@ -160,14 +169,6 @@ typedef enum { /* Global var to tell us which I/O manager impl we are using */ extern IOManagerType iomgr_type; -#if defined(mingw32_HOST_OS) -/* Global var (only on Windows) that is exported to be shared with the I/O code - * in the base library to tell us which style of I/O manager we are using: one - * that uses the Windows native API HANDLEs, or one that uses Posix style fds. - */ -extern bool rts_IOManagerIsWin32Native; -#endif - /* The CapIOManager is the per-capability data structure belonging to the I/O * manager. It is defined in full in IOManagerInternals.h. The opaque forward ===================================== rts/Linker.c ===================================== @@ -478,16 +478,7 @@ initLinker_ (int retain_cafs) symhash = allocStrHashTable(); /* populate the symbol table with stuff from the RTS */ - IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n")); - for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) { - IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr)); - if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"), - symhash, sym->lbl, sym->addr, - sym->strength, sym->type, 0, NULL)) { - barf("ghciInsertSymbolTable failed"); - } - } - IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n")); + initLinkerRtsSyms(symhash); /* Add extra symbols. rtsExtraSyms() is a weakly defined symbol in the rts, * 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, void initSegment(Segment *s, void *start, size_t size, SegmentProt prot, int n_sections); void freeSegments(ObjectCode *oc); +void initLinkerRtsSyms(StrHashTable *symhash); + #include "EndPrivate.h" ===================================== rts/RtsSymbols.c ===================================== @@ -9,6 +9,8 @@ #include "ghcplatform.h" #include "Rts.h" #include "RtsSymbols.h" +#include "LinkerInternals.h" +#include "PathUtils.h" #include "TopHandler.h" #include "HsFFI.h" @@ -51,6 +53,20 @@ extern char **environ; /* ----------------------------------------------------------------------------- * Symbols to be inserted into the RTS symbol table. + * + * Note [Naming Scheme for Symbol Macros] + * ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * + * SymI_*: symbol is internal to the RTS. It resides in an object + * file/library that is linked into the RTS library (as a static + * archive or dynamic shared library). + * SymE_*: symbol is external to the RTS library. It might be linked + * dynamically. + * + * Sym*_HasProto : the symbol prototype is imported in an include file + * or defined explicitly + * Sym*_NeedsProto: the symbol is undefined and we add a dummy + * default proto extern void sym(void); */ #define Maybe_Stable_Names SymI_HasProto(stg_mkWeakzh) \ @@ -162,7 +178,7 @@ extern char **environ; SymI_HasProto(stg_asyncWritezh) \ SymI_HasProto(stg_asyncDoProczh) \ SymI_HasProto(rts_InstallConsoleEvent) \ - SymI_HasProto(rts_IOManagerIsWin32Native) \ + SymI_HasDataProto(rts_IOManagerIsWin32Native) \ SymI_HasProto(rts_ConsoleHandlerDone) \ SymI_NeedsProto(__mingw_module_is_dll) \ RTS_WIN64_ONLY(SymI_NeedsProto(___chkstk_ms)) \ @@ -914,7 +930,7 @@ extern char **environ; SymI_HasProto(freeExecPage) \ SymI_HasProto(getAllocations) \ SymI_HasProto(revertCAFs) \ - SymI_HasProto(RtsFlags) \ + SymI_HasDataProto(RtsFlags) \ SymI_NeedsDataProto(rts_breakpoint_io_action) \ SymI_NeedsDataProto(rts_stop_next_breakpoint) \ SymI_NeedsDataProto(rts_stop_on_exception) \ @@ -925,9 +941,9 @@ extern char **environ; SymI_NeedsProto(rts_enableStopAfterReturn) \ SymI_NeedsProto(rts_disableStopAfterReturn) \ SymI_HasProto(stopTimer) \ - SymI_HasProto(n_capabilities) \ - SymI_HasProto(max_n_capabilities) \ - SymI_HasProto(enabled_capabilities) \ + SymI_HasDataProto(n_capabilities) \ + SymI_HasDataProto(max_n_capabilities) \ + SymI_HasDataProto(enabled_capabilities) \ SymI_HasDataProto(stg_traceEventzh) \ SymI_HasDataProto(stg_traceMarkerzh) \ SymI_HasDataProto(stg_traceBinaryEventzh) \ @@ -1145,12 +1161,27 @@ extern char **environ; SymI_HasProto(hs_word2float64) -/* entirely bogus claims about types of these symbols */ -#define SymI_NeedsProto(vvv) extern void vvv(void); -#define SymI_NeedsDataProto(vvv) extern StgWord vvv[]; -#define SymE_NeedsProto(vvv) SymI_NeedsProto(vvv); -#define SymE_NeedsDataProto(vvv) SymI_NeedsDataProto(vvv); -#define SymE_HasProto(vvv) SymI_HasProto(vvv); +/* Declare prototypes for the symbols that need it, so we can refer + * to them in the rtsSyms table below. + * + * In particular, for the external ones (SymE_*) we use the dllimport attribute + * to indicate that (on Windows) they come from external DLLs. This attribute + * is ignored on other platforms. + * + * The claims about the types of these symbols are entirely bogus. + */ +#if defined(mingw32_HOST_OS) && defined(DYNAMIC) +#define DLLIMPORT __attribute__((dllimport)) +#else +#define DLLIMPORT /**/ +#endif + +#define SymI_NeedsProto(vvv) extern void vvv(void); +#define SymI_NeedsDataProto(vvv) extern StgWord vvv[]; +#define SymE_NeedsProto(vvv) extern DLLIMPORT void vvv(void); +#define SymE_NeedsDataProto(vvv) extern DLLIMPORT StgWord vvv[]; + +#define SymE_HasProto(vvv) /**/ #define SymI_HasProto(vvv) /**/ #define SymI_HasDataProto(vvv) /**/ #define SymI_HasProto_redirect(vvv,xxx,strength,ty) /**/ @@ -1179,6 +1210,8 @@ RTS_SYMBOLS_PRIM #undef SymE_NeedsProto #undef SymE_NeedsDataProto +/* See Note [Naming Scheme for Symbol Macros] */ + #define SymI_HasProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \ (void*)(&(vvv)), STRENGTH_NORMAL, SYM_TYPE_CODE }, #define SymI_HasDataProto(vvv) { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \ @@ -1199,7 +1232,16 @@ RTS_SYMBOLS_PRIM { MAYBE_LEADING_UNDERSCORE_STR(#vvv), \ (void*)(&(xxx)), strength, ty }, -RtsSymbolVal rtsSyms[] = { + + +/* Initialize (if not already initialized) and return an array of symbols with stuff from the RTS. */ +void initLinkerRtsSyms (StrHashTable *symhash) { + /* The address of data symbols with the dllimport attribute are not + * compile-time constants and so cannot be used in constant initialisers. + * For this reason, rtsSyms is a local variable within this function + * rather than a global constant (as it was historically). + */ + const RtsSymbolVal rtsSyms[] = { RTS_SYMBOLS RTS_RET_SYMBOLS RTS_POSIX_ONLY_SYMBOLS @@ -1214,7 +1256,20 @@ RtsSymbolVal rtsSyms[] = { RTS_SYMBOLS_PRIM SymI_HasDataProto(nonmoving_write_barrier_enabled) { 0, 0, STRENGTH_NORMAL, SYM_TYPE_CODE } /* sentinel */ -}; + }; + + IF_DEBUG(linker, debugBelch("populating linker symbol table with built-in RTS symbols\n")); + for (const RtsSymbolVal *sym = rtsSyms; sym->lbl != NULL; sym++) { + IF_DEBUG(linker, debugBelch("initLinker: inserting rts symbol %s, %p\n", sym->lbl, sym->addr)); + if (! ghciInsertSymbolTable(WSTR("(GHCi built-in symbols)"), + symhash, sym->lbl, sym->addr, + sym->strength, sym->type, 0, NULL)) { + barf("ghciInsertSymbolTable failed"); + } + } + IF_DEBUG(linker, debugBelch("done with built-in RTS symbols\n")); +} + // Note [Extra RTS symbols] ===================================== rts/RtsSymbols.h ===================================== @@ -46,8 +46,6 @@ typedef struct _RtsSymbolVal { SymType type; } RtsSymbolVal; -extern RtsSymbolVal rtsSyms[]; - extern RtsSymbolVal* __attribute__((weak)) rtsExtraSyms(void); /* See Note [_iob_func symbol]. */ ===================================== rts/linker/Elf.c ===================================== @@ -76,18 +76,6 @@ * * See bug #781 * See thread http://www.haskell.org/pipermail/cvs-ghc/2007-September/038458.html - * - * Naming Scheme for Symbol Macros - * - * SymI_*: symbol is internal to the RTS. It resides in an object - * file/library that is statically. - * SymE_*: symbol is external to the RTS library. It might be linked - * dynamically. - * - * Sym*_HasProto : the symbol prototype is imported in an include file - * or defined explicitly - * Sym*_NeedsProto: the symbol is undefined and we add a dummy - * default proto extern void sym(void); */ #define X86_64_ELF_NONPIC_HACK (!RtsFlags.MiscFlags.linkerAlwaysPic) ===================================== testsuite/tests/MiniQuickCheck.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralisedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} -- | A minimal QuickCheck-like property testing framework for use in the GHC @@ -52,6 +53,8 @@ module MiniQuickCheck ) where -- base +import Control.Exception + ( SomeException, displayException, evaluate, try ) import Control.Monad.IO.Class ( liftIO ) import Data.Bits @@ -181,16 +184,39 @@ nest :: String -> ReaderT RunS IO a -> ReaderT RunS IO a nest c = local (\s -> s { depth = depth s + 1, context = c : context s }) runPropertyCheck :: PropertyCheck -> ReaderT RunS IO Result -runPropertyCheck (PropertyBinaryOp ok desc s1 s2) = - if ok - then return Success - else do - ctx <- context <$> ask - let msg = "Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2 - putMsg msg - return (Failure [msg : ctx]) -runPropertyCheck (PropertyAnd a b) = - (<>) <$> runPropertyCheck a <*> runPropertyCheck b +runPropertyCheck pcThunk = do + -- See Note [Catching exceptions in property evaluation]. + pcRes <- liftIO $ try @SomeException (evaluate pcThunk) + case pcRes of + Left e -> reportFailure ("Failure: exception: " ++ displayException e) + Right (PropertyAnd a b) -> + (<>) <$> runPropertyCheck a <*> runPropertyCheck b + Right (PropertyBinaryOp ok desc s1 s2) -> do + okRes <- liftIO $ try @SomeException (evaluate ok) + case okRes of + Right True -> return Success + Right False -> reportFailure ("Failure: " ++ s1 ++ " " ++ desc ++ " " ++ s2) + Left e -> reportFailure ("Failure: exception: " ++ displayException e) + +reportFailure :: String -> ReaderT RunS IO Result +reportFailure msg = do + ctx <- context <$> ask + putMsg msg + return (Failure [msg : ctx]) + +-- Note [Catching exceptions in property evaluation] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- A property like `\a b -> let !r = a `div` 0 in r === b` builds a +-- `PropertyCheck` thunk whose forcing raises an exception -- in this case +-- already at the `PropertyBinaryOp` constructor, before its `ok` field is +-- ever inspected. Other properties may force `ok = (s1 == s2)` instead and +-- raise from there. +-- +-- To handle both, we `evaluate` first the `PropertyCheck` thunk and then +-- the `ok` field, each inside `try`, and report any exception through the +-- normal `reportFailure` path. The surrounding loop then still prints +-- "With arguments ... (Seed: ...)" and the test driver continues with +-- subsequent properties instead of aborting. runProperty :: Iterations -> Property -> ReaderT RunS IO Result runProperty (Iterations iters) (Prop p) = do ===================================== testsuite/tests/linters/notes.stdout ===================================== @@ -27,7 +27,6 @@ ref compiler/GHC/Tc/Solver/Rewrite.hs:1020:7: Note [Stability of rewritin ref compiler/GHC/Tc/TyCl.hs:1662:6: Note [Unification variables need fresh Names] ref compiler/GHC/Tc/Types/Constraint.hs:209:9: Note [NonCanonical Semantics] ref compiler/GHC/Types/Demand.hs:304:25: Note [Preserving Boxity of results is rarely a win] -ref compiler/GHC/Unit/Module/Deps.hs:97:13: Note [Structure of dep_boot_mods] ref compiler/GHC/Utils/Monad.hs:415:34: Note [multiShotIO] ref compiler/Language/Haskell/Syntax/Binds.hs:206:31: Note [fun_id in Match] ref configure.ac:205:10: Note [Linking ghc-bin against threaded stage0 RTS] ===================================== testsuite/tests/numeric/should_run/foundation.hs ===================================== @@ -77,13 +77,42 @@ testMultiplicative _ = Group "Multiplicative" , Property "a * b == Integer(a) * Integer(b)" $ \(a :: a) (b :: a) -> a * b === fromInteger (toInteger a * toInteger b) ] -testDividible :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a) +-- | Divisibility test for Bounded Integral types (Int, Int{8,16,32,64}, +-- Word, Word{8,16,32,64}). +testDivisible :: forall a . (Show a, Eq a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test -testDividible _ = Group "Divisible" +testDivisible _ = Group "Divisible" + [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) -> + -- See Note [Skipping minBound `div` (-1)]. + if (minBound :: a) < 0 && a == minBound && b == (-1) + then True === True + else a === (a `div` b) * b + (a `mod` b) + ] + +-- | Divisibility test for unbounded Integral types (Integer). No overflow +-- can occur here, so the property holds without exception for all NonZero b. +testDivisibleUnbounded :: forall a . (Show a, Eq a, Integral a, Num a, Arbitrary a, Typeable a) + => Proxy a -> Test +testDivisibleUnbounded _ = Group "Divisible" [ Property "(x `div` y) * y + (x `mod` y) == x" $ \(a :: a) (NonZero b) -> a === (a `div` b) * b + (a `mod` b) ] +-- Note [Skipping minBound `div` (-1)] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- For a fixed-width *signed* Integral type, `minBound `div` (-1)` raises +-- ArithException(Overflow) because `-minBound` is not representable in the +-- type (e.g., for Int8, `-(-128)` would be 128, out of range). The div/mod +-- identity property cannot hold there, so we skip exactly that one pair. +-- +-- We detect "signed Bounded" with `(minBound :: a) < 0`: True for Int{N}, +-- False for Word{N}. This way unsigned Bounded types lose no coverage, +-- and only the genuine overflow sample is skipped for signed types. +-- +-- For the unbounded `Integer`, no overflow can occur and we use a separate +-- 'testDivisibleUnbounded' (without the Bounded constraint or the skip). +-- See #27222. + testOperatorPrecedence :: forall a . (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) => Proxy a -> Test testOperatorPrecedence _ = Group "Precedence" @@ -101,14 +130,26 @@ testOperatorPrecedence _ = Group "Precedence" ] -testNumber :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) +testNumber :: (Show a, Eq a, Prelude.Num a, Bounded a, Integral a, Num a, Arbitrary a, Typeable a) => String -> Proxy a -> Test testNumber name proxy = Group name [ testIntegral proxy , testEqOrd proxy , testAdditive proxy , testMultiplicative proxy - , testDividible proxy + , testDivisible proxy + , testOperatorPrecedence proxy + ] + +-- | Variant of 'testNumber' for unbounded Integral types (e.g., Integer). +testNumberUnbounded :: (Show a, Eq a, Prelude.Num a, Integral a, Num a, Arbitrary a, Typeable a) + => String -> Proxy a -> Test +testNumberUnbounded name proxy = Group name + [ testIntegral proxy + , testEqOrd proxy + , testAdditive proxy + , testMultiplicative proxy + , testDivisibleUnbounded proxy , testOperatorPrecedence proxy ] @@ -119,7 +160,7 @@ testNumberRefs = Group "ALL" , testNumber "Int16" (Proxy :: Proxy Int16) , testNumber "Int32" (Proxy :: Proxy Int32) , testNumber "Int64" (Proxy :: Proxy Int64) - , testNumber "Integer" (Proxy :: Proxy Integer) + , testNumberUnbounded "Integer" (Proxy :: Proxy Integer) , testNumber "Word" (Proxy :: Proxy Word) , testNumber "Word8" (Proxy :: Proxy Word8) , testNumber "Word16" (Proxy :: Proxy Word16) @@ -399,7 +440,7 @@ testPrimops = Group "primop" , testPrimop "-#" (Primop.-#) (Wrapper.-#) , testPrimop "*#" (Primop.*#) (Wrapper.*#) , testPrimop "timesInt2#" Primop.timesInt2# Wrapper.timesInt2# - , testPrimop "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo# + , testPrimopMayOflo "mulIntMayOflo#" Primop.mulIntMayOflo# Wrapper.mulIntMayOflo# , testPrimopDivLike "quotInt#" Primop.quotInt# Wrapper.quotInt# , testPrimopDivLike "remInt#" Primop.remInt# Wrapper.remInt# , testPrimopDivLike "quotRemInt#" Primop.quotRemInt# Wrapper.quotRemInt# @@ -497,6 +538,31 @@ instance TestPrimop (Int# -> Int# -> Int#) where testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> wInt# (l x0 x1) === wInt# (r x0 x1) testPrimopShift s l r = Property s $ \ (uInt#-> x0) (BoundedShiftAmount @Int shift) -> wInt# (l x0 (uInt# shift)) === wInt# (r x0 (uInt# shift)) +-- | Compare two 'mulIntMayOflo#'-like primops only on whether their result +-- is zero. See Note [Comparing mulIntMayOflo# results]. +testPrimopMayOflo :: String + -> (Int# -> Int# -> Int#) + -> (Int# -> Int# -> Int#) + -> Test +testPrimopMayOflo s l r = + Property s $ \ (uInt# -> x0) (uInt# -> x1) -> + (wInt# (l x0 x1) == 0) === (wInt# (r x0 x1) == 0) + +-- Note [Comparing mulIntMayOflo# results] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- The 'mulIntMayOflo#' primop is only specified to return 0 if the signed +-- multiplication does not overflow, and a non-zero value if it /may/ +-- overflow (see Note [MO_S_MulMayOflo significant width] in +-- GHC.Cmm.MachOp). The exact non-zero value is unspecified and legitimately +-- differs between backends and between inlined vs. non-inlined call sites +-- (e.g., the LLVM backend's `isSMulOK` returns `sext_signbit(low) - high`, +-- which is some arbitrary non-zero word on overflow). +-- +-- Comparing the raw Int# results bit-for-bit is therefore too strict and +-- causes spurious test failures whenever the random arguments happen to +-- overflow. We compare zero/non-zero instead, which matches the spec. +-- See #27222. + instance TestPrimop (Int# -> Int# -> (# Int#,Int# #)) where testPrimop s l r = Property s $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) testPrimopDivLike s l r = Property s $ twoNonZero $ \ (uInt#-> x0) (uInt#-> x1) -> WTUP2(wInt#,wInt#, (l x0 x1)) === WTUP2(wInt#,wInt#, (r x0 x1)) ===================================== testsuite/tests/th/T27022.hs ===================================== @@ -0,0 +1,8 @@ +{-# LANGUAGE TemplateHaskell #-} +-- | This tests the behaviour of TH's recover method. +-- It should behave the same in the internal and external interperter. +-- In the past, they have diverged, and the external interpreter would roll back the state of putQ/getQ whereas the internal interpreter would not. +module Main where + +import Language.Haskell.TH.Syntax +main = print $(putQ "0" >> recover (pure ()) (putQ "42" >> fail "oops") >> getQ @String >>= lift ) ===================================== testsuite/tests/th/T27022.stdout ===================================== @@ -0,0 +1 @@ +Just "42" ===================================== testsuite/tests/th/all.T ===================================== @@ -650,3 +650,4 @@ test('GadtConSigs_th_dump1', normal, compile, ['-v0 -ddump-splices -dsuppress-un test('T26099', normal, compile_fail, ['']) test('T8306_th', only_ways(['ghci']), ghci_script, ['T8306_th.script']) test('T26862_th', only_ways(['ghci']), ghci_script, ['T26862_th.script']) +test('T27022', normal, compile_and_run, ['']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4441dabbcfa6dda03992fb96d4773b8... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4441dabbcfa6dda03992fb96d4773b8... You're receiving this email because of your account on gitlab.haskell.org.