Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: ca7a8e7f by Brandon Chinn at 2026-08-25T13:21:35-04:00 Add Data.RealFloat and Infinity/NegInfinity/NaN pattern synonyms (#26961) - - - - - 95884a75 by Andreas Klebinger at 2026-08-25T13:21:38-04:00 rts linker: Fix pointer arithmetic issue in flushInstructionCacheRISCV64 We accidentally operated over `uint64_t*` when we should use `uint8_t`. Fixes #27569 - - - - - 7e6dabb4 by Zubin Duggal at 2026-08-25T13:21:40-04:00 ghc-internal: annotateSTM should use catchSTM# rather than catch# A catch# frame inside a transaction breaks retry and async exception delivery. Fixes #27657 - - - - - ee8a334d by Rodrigo Mesquita at 2026-08-25T13:21:41-04:00 rts: refactor to reduce THREADED_RTS in MSG_UPD_TSO_FLAGS - No behavior change in this commit (well, a small optimization here makes us do less work if the target TSO owned by the curr. capability) - Move all THREADED_RTS CPP needed into `updThreadFlag` - Merge MSG_SET_TSO_FLAGS and MSG_UNSET_TSO_FLAGS into MSG_UPD_TSO_FLAGS plus a `set` bool field in the MessageUpdTSOFlag struct Towards #27729 - - - - - bd7a24fb by Rodrigo Mesquita at 2026-08-25T13:21:41-04:00 rts: Fix race condition in MSG_UPD_TSO_FLAGS execution The code for processing the MSG_UPD_TSO_FLAGS message was not taking into consideration that the TSO's owner might have moved in between that capability receiving the message (since it was its previous owner) and starting to process its inbox (a point at which it was no longer the owner) Added Note [TSO owner may change in between Msg being sent and received] to explain this race and the pattern used to fix this, where we just forward the message to the new owner. Fixes #27729 - - - - - 51021cd3 by Alan Zimmerman at 2026-08-25T13:21:41-04:00 EPA: Uses Parsers.parseModule for exactprint tests Parsers.parseModule is the advertised way to parse for use for exact printing in the ghc-exactprint library. This commit updates the GHC exact print testing to use it. This requires moving the comment balancing that was occurring only in the test path into the advertising parser path, so it moves from Transforms.hs to Utils.hs. Also update the comment adding to honour trailing annotations - - - - - 27 changed files: - + changelog.d/T27657 - libraries/base/base.cabal.in - libraries/base/changelog.md - + libraries/base/src/Data/RealFloat.hs - libraries/ghc-internal/src/GHC/Internal/STM.hs - rts/CloneStack.c - rts/Interpreter.c - rts/Messages.c - rts/StgMiscClosures.cmm - rts/Threads.c - rts/Threads.h - rts/include/rts/storage/Closures.h - rts/include/stg/MiscClosures.h - rts/linker/elf_reloc_riscv64.c - + testsuite/tests/concurrent/should_run/T27657a.hs - + testsuite/tests/concurrent/should_run/T27657a.stdout - + testsuite/tests/concurrent/should_run/T27657b.hs - + testsuite/tests/concurrent/should_run/T27657b.stdout - testsuite/tests/concurrent/should_run/all.T - testsuite/tests/interface-stability/base-exports.stdout - testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs - testsuite/tests/interface-stability/base-exports.stdout-mingw32 - utils/check-exact/ExactPrint.hs - utils/check-exact/Main.hs - utils/check-exact/Parsers.hs - utils/check-exact/Transform.hs - utils/check-exact/Utils.hs Changes: ===================================== changelog.d/T27657 ===================================== @@ -0,0 +1,9 @@ +section: base +issues: #27657 +mrs: !16508 +synopsis: + Fix ``retry`` and async exception delivery inside a ``catchSTM`` handler +description: + ``catchSTM``\'s ``WhileHandling`` annotation used ``catch#``, leaving an IO + ``CATCH_FRAME`` inside the transaction. Use ``catchSTM#``, which is the + correct way to catch exceptions inside STM. ===================================== libraries/base/base.cabal.in ===================================== @@ -117,6 +117,7 @@ Library , Data.Monoid , Data.Ord , Data.Proxy + , Data.RealFloat , Data.STRef , Data.STRef.Strict , Data.String ===================================== libraries/base/changelog.md ===================================== @@ -9,6 +9,8 @@ * Introduce `Data.Double` and `Data.Float` modules. ([CLC proposal #378](https://github.com/haskell/core-libraries-committee/issues/378)) * Change `Generically a`'s `Monoid` definition to require a `Semigroup` constraint, and define its `mconcat` using `(<>)` from that constraint. ([CLC proposal #413](https://github.com/haskell/core-libraries-committee/issues/413)) * Add `withEmptyCallStack` to `GHC.Stack`. ([CLC proposal #428](https://github.com/haskell/core-libraries-committee/issues/428)) + * Add new `Data.RealFloat` module re-exporting `RealFloat` from `GHC.Float` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) + * Add `Infinity`, `NegInfinity`, and `NaN` pattern synonyms to `Data.RealFloat` ([CLC proposal #394](https://github.com/haskell/core-libraries-committee/issues/394)) ## 4.23.0.0 *TBA* * Add `System.IO.hGetNewlineMode`. ([CLC proposal #370](https://github.com/haskell/core-libraries-committee/issues/370)) ===================================== libraries/base/src/Data/RealFloat.hs ===================================== @@ -0,0 +1,59 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE ViewPatterns #-} + +-- | +-- +-- Module : Data.RealFloat +-- Copyright : (c) The University of Glasgow 2026 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- + +module Data.RealFloat ( + RealFloat (..), + + -- * Infinity + NaN + pattern Infinity, + pattern NegInfinity, + pattern NaN, +) where + +import Data.Bool (Bool (..), (&&)) +import GHC.Internal.Data.Ord ((<), (>)) +import GHC.Internal.Float (RealFloat (..)) +import GHC.Internal.Real ((/)) +#if __GLASGOW_HASKELL__ >= 1001 +import qualified GHC.Essentials as Rebindable +#endif + +pattern Infinity :: (RealFloat a) => a +pattern Infinity <- ((\x -> isInfinite x && x > 0) -> True) where Infinity = 1/0 + +-- | Negative infinity +-- +-- Provided for convenience. Could also use the following instead: +-- * Pattern matching: @(negate -> Infinity)@ +-- * Expressions: @-Infinity@ +pattern NegInfinity :: (RealFloat a) => a +pattern NegInfinity <- ((\x -> isInfinite x && x < 0) -> True) where NegInfinity = -1/0 + +-- | A pattern synonym for NaN values. +-- +-- Note: Per IEEE 754, NaN is never equal to itself, thus these two snippets +-- have different behavior: +-- +-- @ +-- -- foo1 NaN == "a" +-- foo1 NaN = "a" +-- foo1 _ = "b" +-- +-- -- foo2 NaN == "b" +-- foo2 x = if x == NaN then "a" else "b" +-- @ +pattern NaN :: (RealFloat a) => a +pattern NaN <- (isNaN -> True) where NaN = 0/0 ===================================== libraries/ghc-internal/src/GHC/Internal/STM.hs ===================================== @@ -31,7 +31,7 @@ import GHC.Internal.Exception.Context (ExceptionAnnotation) import GHC.Internal.Exception.Type (WhileHandling(..)) import GHC.Internal.Maybe (Maybe(..)) import GHC.Internal.Prim ( - RealWorld, State#, TVar#, atomically#, catch#, catchRetry#, catchSTM#, + RealWorld, State#, TVar#, atomically#, catchRetry#, catchSTM#, newTVar#, raiseIO#, readTVar#, readTVarIO#, retry#, writeTVar#, ) import GHC.Internal.Prim.PtrEq (sameTVar#) @@ -213,7 +213,7 @@ catchSTM (STM m) handler = STM $ catchSTM# m handler' -- | Execute an 'STM' action, adding the given 'ExceptionContext' -- to any thrown synchronous exceptions. annotateSTM :: forall e a. ExceptionAnnotation e => e -> STM a -> STM a -annotateSTM ann (STM io) = STM (catch# io handler) +annotateSTM ann (STM io) = STM (catchSTM# io handler) -- not catch#, see #27657 where handler se = raiseIO# (addExceptionContext ann se) ===================================== rts/CloneStack.c ===================================== @@ -88,6 +88,7 @@ void sendCloneStackMessage(StgTSO *tso, HsStablePtr mvar) { void handleCloneStackMessage(Capability *cap, MessageCloneStack *msg){ // We must check that the current owner of the thread we want to clone the stack for // is still this capability. + // See Note [TSO owner may change in between Msg being sent and received] Capability *owner = RELAXED_LOAD(&msg->tso->cap); if (owner != cap) { // The target TSO may have migrated after the message was queued on the old ===================================== rts/Interpreter.c ===================================== @@ -416,22 +416,14 @@ void rts_disableStopNextBreakpointAll(void) void rts_enableStopNextBreakpoint(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); setThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT); -#else - tso->flags |= TSO_STOP_NEXT_BREAKPOINT; -#endif } void rts_disableStopNextBreakpoint(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); unsetThreadFlag(cap, tso, TSO_STOP_NEXT_BREAKPOINT); -#else - tso->flags &= ~TSO_STOP_NEXT_BREAKPOINT; -#endif } /* --------------------------------------------------------------------------- @@ -440,22 +432,14 @@ void rts_disableStopNextBreakpoint(StgTSO* tso) void rts_enableStopAfterReturn(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); setThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN); -#else - tso->flags |= TSO_STOP_AFTER_RETURN; -#endif } void rts_disableStopAfterReturn(StgTSO* tso) { -#if defined(THREADED_RTS) Capability* cap = rts_unsafeGetMyCapability(); unsetThreadFlag(cap, tso, TSO_STOP_AFTER_RETURN); -#else - tso->flags &= ~TSO_STOP_AFTER_RETURN; -#endif } /* ===================================== rts/Messages.c ===================================== @@ -36,8 +36,7 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) i != &stg_IND_info && // can happen if a MSG_BLACKHOLE is revoked i != &stg_WHITEHOLE_info && i != &stg_MSG_CLONE_STACK_info && - i != &stg_MSG_SET_TSO_FLAG_info && - i != &stg_MSG_UNSET_TSO_FLAG_info) { + i != &stg_MSG_UPD_TSO_FLAG_info) { barf("sendMessage: %p", i); } } @@ -67,6 +66,62 @@ void sendMessage(Capability *from_cap, Capability *to_cap, Message *msg) Handle a message ------------------------------------------------------------------------- */ +/* +Note [TSO owner may change in between Msg being sent and received] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When a message is sent from Capability (C1) to a target TSO (T2) (e.g. +MessageUpdTSOFlag, MessageCloneStack, ...), it is queued on the TSO's owner +Capability (C3) inbox (inboxes are owned by Capabilities, not TSOs). + +At a later point, the Capability (C3) will process its inbox. Upon receiving +the message meant for a specific TSO (T2), it must first always check that the +TSO's owner is *still* itself (C3). + +The target TSO (T2) may have migrated after the message was queued on its old +capability (C3). In that case we must forward the request to the new owner +(say, C4); otherwise the Capability C3 could be modifying a TSO it no longer +owns, racing with its actual owner mutating it, since it is no longer the owner. + +The message meant for a TSO should only be executed when the receiving +Capability is still the owner of that TSO. Otherwise, it must be forwarded to +the new owner. + +The general pattern is one where there's a top-level function which assumes it +can be called by capabilities other than the TSO's owner. The function checks +whether the current capability is the TSO owner. If yes, execute the action. If +not, then it sends a message to the current TSO's owner. On receiving the +message, the new capability will just call that top-level function, which will +ensure the message is forwarded again if the TSO owner changed. +It will look something like: + + runMyMsg(Capability *from, StgTSO *target, ...) { + +#if defined(THREADED_RTS) + Capability *owner = RELAXED_LOAD(&target->cap) + if (owner != from) { + MessageMyMsg* msg = ... + sendMessage(cap, owner, msg) + return + } +#endif + + actuallyDoTheWork(...) + } + + executeMessage(...) { + + if (i == &stg_MY_MSG_info) { + + MessageMyMsg* msg = (MessageMyMsg*) m + runMyMsg(cap, m->tso, ...) + + } + } + +See example `updThreadFlag` and `executeMessage`'s `stg_MSG_UPD_TSO_FLAG_info`, +or `tryWakeUpThread` and `stg_MSG_TRY_WAKEUP_info` for two live examples. +*/ + #if defined(THREADED_RTS) void @@ -141,15 +196,11 @@ loop: MessageCloneStack *cloneStackMessage = (MessageCloneStack*) m; handleCloneStackMessage(cap, cloneStackMessage); } - else if(i == &stg_MSG_SET_TSO_FLAG_info){ + else if(i == &stg_MSG_UPD_TSO_FLAG_info){ MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; - u->tso->flags |= u->flag; - return; - } - else if(i == &stg_MSG_UNSET_TSO_FLAG_info){ - MessageUpdTSOFlag *u = (MessageUpdTSOFlag*) m; - u->tso->flags &= ~u->flag; - return; + + StgTSO *tso = RELAXED_LOAD(&u->tso); + updThreadFlag(cap, tso, u->flag, u->set); } else { ===================================== rts/StgMiscClosures.cmm ===================================== @@ -855,11 +855,8 @@ INFO_TABLE_CONSTR(stg_MSG_NULL,1,0,0,PRIM,"MSG_NULL","MSG_NULL") INFO_TABLE_CONSTR(stg_MSG_CLONE_STACK,3,0,0,PRIM,"MSG_CLONE_STACK","MSG_CLONE_STACK") { ccall pbarf("stg_MSG_CLONE_STACK object (%p) entered!", R1 "ptr") never returns; } -INFO_TABLE_CONSTR(stg_MSG_SET_TSO_FLAG,2,1,0,PRIM,"MSG_SET_TSO_FLAG","MSG_SET_TSO_FLAG") -{ foreign "C" barf("stg_MSG_SET_TSO_FLAG object (%p) entered!", R1) never returns; } - -INFO_TABLE_CONSTR(stg_MSG_UNSET_TSO_FLAG,2,1,0,PRIM,"MSG_UNSET_TSO_FLAG","MSG_UNSET_TSO_FLAG") -{ foreign "C" barf("stg_MSG_UNSET_TSO_FLAG object (%p) entered!", R1) never returns; } +INFO_TABLE_CONSTR(stg_MSG_UPD_TSO_FLAG,2,2,0,PRIM,"MSG_UPD_TSO_FLAG","MSG_UPD_TSO_FLAG") +{ foreign "C" barf("stg_MSG_UPD_TSO_FLAG object (%p) entered!", R1) never returns; } /* ---------------------------------------------------------------------------- END_TSO_QUEUE ===================================== rts/Threads.c ===================================== @@ -379,32 +379,46 @@ migrateThread (Capability *from, StgTSO *tso, Capability *to) sets or unsets a flag in a given TSO ------------------------------------------------------------------------- */ -#if defined(THREADED_RTS) -static void -updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info); - void setThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) { - updThreadFlag(from, tso, flag, &stg_MSG_SET_TSO_FLAG_info); + updThreadFlag(from, tso, flag, true); } void unsetThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag) { - updThreadFlag(from, tso, flag, &stg_MSG_UNSET_TSO_FLAG_info); + updThreadFlag(from, tso, flag, false); } -static void -updThreadFlag(Capability *from, StgTSO *tso, StgWord32 flag, const StgInfoTable* info) +void +updThreadFlag(Capability *from USED_IF_THREADS, StgTSO *tso, StgWord32 flag, StgBool set /* true=set, false=unset */) { - MessageUpdTSOFlag *msg; - msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag)); - msg->tso = tso; - msg->flag = flag; - SET_HDR_RELEASE(msg, info, CCS_SYSTEM); - sendMessage(from, tso->cap, (Message*)msg); -} +#if defined(THREADED_RTS) + // If we're the current owner of the thread we want to modify, do it. + // Otherwise, we must forward the message to the actual owner. + // When executing the upd message, we check again that we're still the TSO + // owner (which may have changed since the message was queued on this cap.) + // See Note [TSO owner may change in between Msg being sent and received] + Capability *tso_owner = RELAXED_LOAD(&tso->cap); + if (from != tso_owner) { + MessageUpdTSOFlag *msg; + msg = (MessageUpdTSOFlag *)allocate(from,sizeofW(MessageUpdTSOFlag)); + msg->tso = tso; + msg->flag = flag; + msg->set = set; + SET_HDR_RELEASE(msg, &stg_MSG_UPD_TSO_FLAG_info, CCS_SYSTEM); + sendMessage(from, tso_owner, (Message*)msg); + return; + } #endif + if (set) { + tso->flags |= flag; + } + else { + tso->flags &= ~flag; + } +} + /* ---------------------------------------------------------------------------- awakenBlockedQueue ===================================== rts/Threads.h ===================================== @@ -19,10 +19,9 @@ void checkBlockingQueues (Capability *cap, StgTSO *tso); void tryWakeupThread (Capability *cap, StgTSO *tso); void migrateThread (Capability *from, StgTSO *tso, Capability *to); -#if defined(THREADED_RTS) void setThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); void unsetThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag); -#endif +void updThreadFlag (Capability *from, StgTSO *tso, StgWord32 flag, StgBool set); // Wakes up a thread on a Capability (probably a different Capability // from the one held by the current Task). ===================================== rts/include/rts/storage/Closures.h ===================================== @@ -625,6 +625,7 @@ typedef struct MessageUpdTSOFlag_ { Message *link; StgTSO *tso; StgWord flag; + StgWord set; // bool: true=SET; false=UNSET } MessageUpdTSOFlag; /* ---------------------------------------------------------------------------- ===================================== rts/include/stg/MiscClosures.h ===================================== @@ -151,8 +151,7 @@ RTS_ENTRY(stg_MSG_TRY_WAKEUP); RTS_ENTRY(stg_MSG_THROWTO); RTS_ENTRY(stg_MSG_BLACKHOLE); RTS_ENTRY(stg_MSG_CLONE_STACK); -RTS_ENTRY(stg_MSG_SET_TSO_FLAG); -RTS_ENTRY(stg_MSG_UNSET_TSO_FLAG); +RTS_ENTRY(stg_MSG_UPD_TSO_FLAG); RTS_ENTRY(stg_MSG_NULL); RTS_ENTRY(stg_MVAR_TSO_QUEUE); RTS_ENTRY(stg_catch); ===================================== rts/linker/elf_reloc_riscv64.c ===================================== @@ -679,7 +679,7 @@ void flushInstructionCacheRISCV64(ObjectCode *oc) { /* The main object code */ void *codeBegin = oc->image + oc->misalignment; - __builtin___clear_cache(codeBegin, (void*) ((uint64_t*) codeBegin + oc->fileSize)); + __builtin___clear_cache(codeBegin, (void*) ((uint8_t*) codeBegin + oc->fileSize)); /* Jump Islands */ __builtin___clear_cache((void *)oc->symbol_extras, ===================================== testsuite/tests/concurrent/should_run/T27657a.hs ===================================== @@ -0,0 +1,15 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- A retry escaping a catchSTM handler must reach the enclosing orElse. An IO +-- CATCH_FRAME in the way trips an assertion in findRetryFrameHelper. + +import Control.Exception +import GHC.Conc + +main :: IO () +main = do + r <- atomically $ + catchSTM (throwSTM (ErrorCall "boom")) + (\(_ :: SomeException) -> retry) + `orElse` pure "T27657a: completed" + putStrLn r ===================================== testsuite/tests/concurrent/should_run/T27657a.stdout ===================================== @@ -0,0 +1 @@ +T27657a: completed ===================================== testsuite/tests/concurrent/should_run/T27657b.hs ===================================== @@ -0,0 +1,40 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- An async exception delivered while a catchSTM handler runs must abort the +-- transaction, not be swallowed by a restart of the invalidated one. + +import Control.Concurrent.MVar +import Control.Exception +import GHC.Conc + +waitParked :: ThreadId -> IO () +waitParked t = do + s <- threadStatus t + case s of + ThreadBlocked BlockedOnMVar -> pure () + _ -> threadDelay 1000 >> waitParked t + +main :: IO () +main = do + tv <- newTVarIO (0 :: Int) + park <- newEmptyMVar + result <- newEmptyMVar + t <- forkIO $ do + r <- try $ atomically $ do + v <- readTVar tv + catchSTM (throwSTM (ErrorCall "boom")) + (\(_ :: SomeException) -> + if v == 0 + then do unsafeIOToSTM (takeMVar park) + pure "handler resumed" + else pure "transaction restarted, exception dropped") + putMVar result (r :: Either SomeException String) + -- parked in the handler, so t cannot revalidate its trec before delivery + waitParked t + atomically (writeTVar tv 1) + killThread t + r <- takeMVar result + putStrLn $ case r of + Left e | Just ThreadKilled <- fromException e -> "T27657b: killThread delivered" + | otherwise -> "T27657b: unexpected exception: " ++ displayException e + Right s -> "T27657b: FAILED, " ++ s ===================================== testsuite/tests/concurrent/should_run/T27657b.stdout ===================================== @@ -0,0 +1 @@ +T27657b: killThread delivered ===================================== testsuite/tests/concurrent/should_run/all.T ===================================== @@ -340,3 +340,6 @@ test('T27105_fail', extra_run_opts('+RTS -C0.2 -RTS'), expect_fail, run_timeout_multiplier(0.05)], multimod_compile_and_run, ['T27105.hs', '']) + +test('T27657a', normal, compile_and_run, ['']) +test('T27657b', normal, compile_and_run, ['']) ===================================== testsuite/tests/interface-stability/base-exports.stdout ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== testsuite/tests/interface-stability/base-exports.stdout-mingw32 ===================================== @@ -1626,6 +1626,29 @@ module Data.Ratio where denominator :: forall a. Ratio a -> a numerator :: forall a. Ratio a -> a +module Data.RealFloat where + -- Safety: Safe + pattern Infinity :: forall a. RealFloat a => a + pattern NaN :: forall a. RealFloat a => a + pattern NegInfinity :: forall a. RealFloat a => a + type RealFloat :: * -> Constraint + class (GHC.Internal.Real.RealFrac a, GHC.Internal.Float.Floating a) => RealFloat a where + floatRadix :: a -> GHC.Internal.Bignum.Integer.Integer + floatDigits :: a -> GHC.Internal.Types.Int + floatRange :: a -> (GHC.Internal.Types.Int, GHC.Internal.Types.Int) + decodeFloat :: a -> (GHC.Internal.Bignum.Integer.Integer, GHC.Internal.Types.Int) + encodeFloat :: GHC.Internal.Bignum.Integer.Integer -> GHC.Internal.Types.Int -> a + exponent :: a -> GHC.Internal.Types.Int + significand :: a -> a + scaleFloat :: GHC.Internal.Types.Int -> a -> a + isNaN :: a -> GHC.Internal.Types.Bool + isInfinite :: a -> GHC.Internal.Types.Bool + isDenormalized :: a -> GHC.Internal.Types.Bool + isNegativeZero :: a -> GHC.Internal.Types.Bool + isIEEE :: a -> GHC.Internal.Types.Bool + atan2 :: a -> a -> a + {-# MINIMAL floatRadix, floatDigits, floatRange, decodeFloat, encodeFloat, isNaN, isInfinite, isDenormalized, isNegativeZero, isIEEE #-} + module Data.STRef where -- Safety: Safe type role STRef nominal representational ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -1465,7 +1465,7 @@ instance ExactPrint (HsModule GhcPs) where Just exps -> do let (op,cp,tcs) = am_exports $ anns an0 op' <- markEpToken op - exps' <- mapM markAnnotated exps + exps' <- mapM markAnnotated (filter notIEDoc exps) tcs' <- mapM markEpToken tcs cp' <- markEpToken cp return (Just exps', an0 { anns = (anns an0) { am_exports = (op',cp',tcs')}}) ===================================== utils/check-exact/Main.hs ===================================== @@ -183,7 +183,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/ -- "../../testsuite/tests/printer/Test17519.hs" Nothing -- "../../testsuite/tests/printer/InTreeAnnotations1.hs" Nothing -- "../../testsuite/tests/printer/Test19798.hs" Nothing - "../../testsuite/tests/printer/Test10309.hs" Nothing + -- "../../testsuite/tests/printer/Test10309.hs" Nothing + "../../testsuite/tests/printer/Haddock1.hs" Nothing -- "../../testsuite/tests/qualifieddo/should_compile/qdocompile001.hs" Nothing -- "../../testsuite/tests/typecheck/should_fail/StrictBinds.hs" Nothing @@ -304,7 +305,7 @@ writeBinFile fpath x = withBinaryFile fpath WriteMode (\h -> hSetEncoding h utf8 testOneFile :: [(String, Changer)] -> FilePath -> String -> Maybe Changer -> IO () testOneFile _ libdir fileName mchanger = do - (p,_toks) <- parseOneFile libdir fileName + p <- parseOneFile libdir fileName let origAst = ppAst p pped = exactPrint p @@ -333,7 +334,7 @@ testOneFile _ libdir fileName mchanger = do changedSource <- readFile newFile return (expectedSource == changedSource, expectedSource, changedSource) - (p',_) <- parseOneFile libdir newFile + p' <- parseOneFile libdir newFile let newAstStr :: String newAstStr = ppAst p' writeBinFile newAstFile newAstStr @@ -364,15 +365,12 @@ testOneFile _ libdir fileName mchanger = do ppAst :: Data a => a -> String ppAst ast = showSDocUnsafe $ showAstData BlankSrcSpanFile NoBlankEpAnnotations ast - -parseOneFile :: FilePath -> FilePath -> IO (ParsedSource, [Located Token]) +parseOneFile :: FilePath -> FilePath -> IO ParsedSource parseOneFile libdir fileName = do - res <- parseModuleEpAnnsWithCpp libdir defaultCppOptions fileName + res <- Parsers.parseModule libdir fileName case res of Left m -> error (internalDebugShowMessages m) - Right (injectedComments, _dflags, pmod) -> do - let !pmodWithComments = insertCppComments pmod injectedComments - return (pmodWithComments, []) + Right pmod -> return pmod -- --------------------------------------------------------------------- @@ -519,8 +517,7 @@ changeLocalDecls libdir (L l p) = do replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs) -> Transform (LMatch GhcPs (LHsExpr GhcPs)) replaceLocalBinds (L lm (Match an mln pats (GRHSs _ rhs (HsValBinds (van,w) (ValBinds _ bs))))) = do - let (oldDecls) = map unWrapValBind bs - -- let decls = s:d:oldDecls + let oldDecls = map unWrapValBind bs let oldDecls' = captureLineSpacing oldDecls let (VbSig o:oldBinds) = map wrapValBind oldDecls' o' = setEntryDP o (DifferentLine 2 0) ===================================== utils/check-exact/Parsers.hs ===================================== @@ -46,6 +46,7 @@ module Parsers ( ) where import Preprocess +import Utils import Data.Functor (void) @@ -270,7 +271,10 @@ postParseTransform -> Either a (GHC.ParsedSource) postParseTransform parseRes = fmap mkAnns parseRes where - mkAnns (_cs, _, m) = fixModuleComments m + mkAnns (cs, _, m) = fixModuleComments (insertCppComments (noIEDoc m) cs) + noIEDoc (GHC.L l m) = case GHC.hsmodExports m of + Nothing -> GHC.L l m + Just exps -> GHC.L l m { GHC.hsmodExports = Just $ filter notIEDoc exps } fixModuleComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleComments p = fixModuleHeaderComments $ fixModuleTrailingComments p ===================================== utils/check-exact/Transform.hs ===================================== @@ -93,7 +93,6 @@ import qualified Control.Monad.Fail as Fail import GHC hiding (parseModule, parsedSource) import GHC.Parser.PostProcess ( wrapValBind ) import GHC.Data.FastString -import GHC.Types.SrcLoc import Data.Data import Data.List (unsnoc) @@ -402,6 +401,14 @@ balanceCommentsList' (a:b:ls) = (a':r) (a',b') = balanceComments a b r = balanceCommentsList' (b':ls) +balanceCommentsListA :: [LocatedA a ] -> [LocatedA a] +balanceCommentsListA [] = [] +balanceCommentsListA [x] = [x] +balanceCommentsListA (a:b:ls) = (a':r) + where + (a',b') = balanceCommentsA a b + r = balanceCommentsListA (b':ls) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -507,15 +514,6 @@ pushTrailingComments w cs lb@(HsValBinds (an,wt) _) = (True, HsValBinds (an',wt) (HsValBinds _ vb') -> vb' _ -> ValBinds noExtField [] - -balanceCommentsListA :: [LocatedA a] -> [LocatedA a] -balanceCommentsListA [] = [] -balanceCommentsListA [x] = [x] -balanceCommentsListA (a:b:ls) = (a':r) - where - (a',b') = balanceCommentsA a b - r = balanceCommentsListA (b':ls) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -591,59 +589,6 @@ priorCommentsDeltas r cs = go r (sortEpaComments cs) -- --------------------------------------------------------------------- --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) -splitComments p cs = (before, middle, after) - where - cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmpe (L _ _) = True - - cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p - cmpb (L _ _) = True - - (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) - (before, middle) = break cmpb beforeEnd - - --- | Split comments into ones occurring before the end of the reference --- span, and those after it. -splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsEnd p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - --- | Split comments into ones occurring before the start of the reference --- span, and those after it. -splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments -splitCommentsStart p (EpaComments cs) = cs' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = case after of - [] -> EpaComments cs - _ -> epaCommentsBalanced before after -splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' - where - cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p - cmp (L _ _) = True - (before, after) = break cmp cs - cs' = before - ts' = after <> ts - moveLeadingComments :: (Data t, Data u, NoAnn t, NoAnn u) => LocatedAn t a -> EpAnn u -> (LocatedAn t a, EpAnn u) moveLeadingComments (L la a) lb = (L la' a, lb') @@ -680,19 +625,6 @@ addCommentOrigDeltasAnn (EpAnn e a cs) = EpAnn e a (addCommentOrigDeltas cs) anchorFromLocatedA :: LocatedA a -> RealSrcSpan anchorFromLocatedA (L (EpAnn anc _ _) _) = epaLocationRealSrcSpan anc --- | Get the full span of interest for comments from a LocatedA. --- This extends up to the last TrailingAnn -fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan -fullSpanFromLocatedA (L (EpAnn anc tas _) _) = rr - where - r = epaLocationRealSrcSpan anc - trailing_loc ta = case ta_location ta of - EpaSpan (RealSrcSpan s _) -> [s] - _ -> [] - rr = case reverse (concatMap trailing_loc tas) of - [] -> r - (s:_) -> combineRealSrcSpans r s - -- --------------------------------------------------------------------- balanceSameLineComments :: LMatch GhcPs (LHsExpr GhcPs) -> (LMatch GhcPs (LHsExpr GhcPs)) ===================================== utils/check-exact/Utils.hs ===================================== @@ -228,7 +228,7 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining (p2, remaining) = insertTopLevelCppComments p1 toplevel addCommentsListItem :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) - addCommentsListItem = addComments + addCommentsListItem = addCommentsA addCommentsList :: EpAnn AnnList -> State [LEpaComment] (EpAnn AnnList) addCommentsList = addComments @@ -249,6 +249,20 @@ insertCppComments (L l p) cs0 = insertRemainingCppComments (L l p2) remaining _ -> return $ EpAnn anc an ocs + addCommentsA :: EpAnn [TrailingAnn] -> State [LEpaComment] (EpAnn [TrailingAnn]) + addCommentsA ann@(EpAnn anc an ocs) = do + case anc of + EpaSpan (RealSrcSpan s _) -> do + unAllocated <- get + let + (rest, these) = GHC.Parser.Lexer.allocateComments (fullSpanFromEpAnnA ann) unAllocated + balanced = splitCommentsEnd s (EpaComments these) + cs' = sortEpAnnComments (ocs <> balanced) + put rest + return $ EpAnn anc an cs' + + _ -> return $ EpAnn anc an ocs + workInComments :: EpAnnComments -> [LEpaComment] -> EpAnnComments workInComments ocs [] = ocs workInComments ocs new = cs' @@ -264,9 +278,14 @@ workInComments ocs new = cs' = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos $ epaLocationRealSrcSpan ac) ) new +sortEpAnnComments :: EpAnnComments -> EpAnnComments +sortEpAnnComments (EpaComments cs) = EpaComments (sortEpaComments cs) +sortEpAnnComments (EpaCommentsBalanced pc fc) + = EpaCommentsBalanced (sortEpaComments pc) (sortEpaComments fc) + insertTopLevelCppComments :: HsModule GhcPs -> [LEpaComment] -> (HsModule GhcPs, [LEpaComment]) insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) cs - = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports' imports' decls', cs3) + = (HsModule (XModulePs an4 lo mdeprec mbDoc) mmn mexports imports' decls', cs3) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0,hc1,hc_cs)) -- `debug` ("insertTopLevelCppComments: (cs2,cs3,hc0i,hc0,hc1,hc_cs)" ++ showAst (cs2,cs3,hc0i,hc0,hc1,hc_cs)) where @@ -297,24 +316,7 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports cs' = workInComments (comments an1) stay _ -> (an1,cs0a) - (mexports', an3, cs1) = - case mexports of - Nothing -> (Nothing, an2, cs0b) - Just exports -> (Just exports', an3', cse) - where - (csh', cs0b') = case am_exports $ anns an2 of - (tokOP, _tokCP, _tokCommas) -> - case tokOP of - (EpTok (EpaSpan (RealSrcSpan s _))) -> (h, n) - where - (h,n) = break (\(L ll _) -> (ss2pos $ epaLocationRealSrcSpan ll) > (ss2pos s) ) - cs0b - - _ -> ([], cs0b) - hc1' = workInComments (comments an2) csh' - an3' = an2 { comments = hc1' } - (exports', cse) = allocPreceding exports cs0b' - (imports0, cs2) = allocPreceding imports cs1 + (imports0, cs2) = allocPreceding imports cs0b (imports', hc0i) = balanceFirstLocatedAComments imports0 (decls0, cs3) = allocPreceding decls cs2 @@ -323,9 +325,9 @@ insertTopLevelCppComments (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports -- Either hc0i or hc0d should have comments. Combine them hc0 = hc0i ++ hc0d - (hc1,hc_cs) = splitOnWhere After (am_where $ anns an3) hc0 - hc2 = workInComments (comments an3) hc1 - an4 = an3 { anns = (anns an3) {am_cs = hc_cs}, comments = hc2 } + (hc1,hc_cs) = splitOnWhere After (am_where $ anns an2) hc0 + hc2 = workInComments (comments an2) hc1 + an4 = an2 { anns = (anns an2) {am_cs = hc_cs}, comments = hc2 } allocPreceding :: [LocatedA a] -> [LEpaComment] -> ([LocatedA a], [LEpaComment]) allocPreceding [] cs' = ([], cs') @@ -346,7 +348,6 @@ annListBracketsLocs (ListSquare o c) = (getEpTokenLoc o, getEpTokenLoc c) annListBracketsLocs (ListBanana o c) = (getEpUniTokenLoc o, getEpUniTokenLoc c) annListBracketsLocs ListNone = (noAnn, noAnn) - data SplitWhere = Before | After splitOnWhere :: SplitWhere -> EpToken "where" -> [LEpaComment] -> ([LEpaComment], [LEpaComment]) @@ -430,6 +431,79 @@ insertRemainingCppComments (L l p) cs = L l p' -- --------------------------------------------------------------------- +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromLocatedA :: LocatedA a -> RealSrcSpan +fullSpanFromLocatedA (L ann _) = fullSpanFromEpAnnA ann + +-- | Get the full span of interest for comments from a LocatedA. +-- This extends up to the last TrailingAnn +fullSpanFromEpAnnA :: EpAnn [TrailingAnn] -> RealSrcSpan +fullSpanFromEpAnnA (EpAnn anc tas _) = rr + where + r = epaLocationRealSrcSpan anc + trailing_loc ta = case ta_location ta of + EpaSpan (RealSrcSpan s _) -> [s] + _ -> [] + rr = case reverse (concatMap trailing_loc tas) of + [] -> r + (s:_) -> combineRealSrcSpans r s + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitComments :: RealSrcSpan -> EpAnnComments -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitComments p cs = (before, middle, after) + where + cmpe (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmpe (L _ _) = True + + cmpb (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2pos p + cmpb (L _ _) = True + + (beforeEnd, after) = break cmpe ((priorComments cs) ++ (getFollowingComments cs)) + (before, middle) = break cmpb beforeEnd + + +-- | Split comments into ones occurring before the end of the reference +-- span, and those after it. +splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsEnd p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsEnd p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- | Split comments into ones occurring before the start of the reference +-- span, and those after it. +splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments +splitCommentsStart p (EpaComments cs) = cs' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = case after of + [] -> EpaComments cs + _ -> epaCommentsBalanced before after +splitCommentsStart p (EpaCommentsBalanced cs ts) = epaCommentsBalanced cs' ts' + where + cmp (L (EpaSpan (RealSrcSpan l _)) _) = ss2pos l > ss2posEnd p + cmp (L _ _) = True + (before, after) = break cmp cs + cs' = before + ts' = after <> ts + +-- --------------------------------------------------------------------- + ghcCommentText :: LEpaComment -> String ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b3be33c377e2e712865d247351603b... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1b3be33c377e2e712865d247351603b... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help