[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 5 commits: EPA: track unicode version for unrestrictedFunTyCon
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Sep 18 14:06:24 UTC 2023
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
f9d79a6c by Alan Zimmerman at 2023-09-18T00:00:14-04:00
EPA: track unicode version for unrestrictedFunTyCon
Closes #23885
Updates haddock submodule
- - - - -
9374f116 by Bodigrim at 2023-09-18T00:00:54-04:00
Bump parsec submodule to allow text-2.1 and bytestring-0.12
- - - - -
65d5b444 by Alexis King at 2023-09-18T10:06:08-04:00
Don’t store the async exception masking state in CATCH frames
- - - - -
98d62eec by Ben Gamari at 2023-09-18T10:06:10-04:00
base: Advertise linear time of readFloat
As noted in #23538, `readFloat` has runtime that scales nonlinearly in
the size of its input. Consequently, its use on untrusted input can
be exploited as a denial-of-service vector. Point this out and suggest
use of `read` instead.
See #23538.
- - - - -
751f109d by Simon Peyton Jones at 2023-09-18T10:06:10-04:00
Remove dead code GHC.CoreToStg.Prep.canFloat
This function never fires, so we can delete it: #23965.
- - - - -
19 changed files:
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- libraries/base/Numeric.hs
- libraries/parsec
- rts/Continuation.c
- rts/Exception.cmm
- rts/RaiseAsync.c
- rts/Schedule.c
- rts/include/rts/storage/Closures.h
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test23885.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/rts/continuations/T23513.hs
- + testsuite/tests/rts/continuations/T23513.stdout
- testsuite/tests/rts/continuations/all.T
- utils/check-exact/ExactPrint.hs
- utils/deriveConstants/Main.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -657,9 +657,6 @@ cpePair top_lvl is_rec dmd is_unlifted env bndr rhs
| allLazyTop floats
= return (floats, rhs)
- | Just floats <- canFloat floats rhs
- = return floats
-
| otherwise
= dontFloat floats rhs
@@ -1954,32 +1951,6 @@ deFloatTop (Floats _ floats)
---------------------------------------------------------------------------
-canFloat :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs)
-canFloat (Floats ok_to_spec fs) rhs
- | OkToSpec <- ok_to_spec -- Worth trying
- , Just fs' <- go nilOL (fromOL fs)
- = Just (Floats OkToSpec fs', rhs)
- | otherwise
- = Nothing
- where
- go :: OrdList FloatingBind -> [FloatingBind]
- -> Maybe (OrdList FloatingBind)
-
- go (fbs_out) [] = Just fbs_out
-
- go fbs_out (fb@(FloatLet _) : fbs_in)
- = go (fbs_out `snocOL` fb) fbs_in
-
- go fbs_out (fb at FloatString{} : fbs_in)
- -- See Note [ANF-ising literal string arguments]
- = go (fbs_out `snocOL` fb) fbs_in
-
- go fbs_out (ft at FloatTick{} : fbs_in)
- = go (fbs_out `snocOL` ft) fbs_in
-
- go _ (FloatCase{} : _) = Nothing
-
-
wantFloatNested :: RecFlag -> Demand -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec dmd rhs_is_unlifted floats rhs
= isEmptyFloats floats
=====================================
compiler/GHC/Parser.y
=====================================
@@ -773,9 +773,9 @@ identifier :: { LocatedN RdrName }
| qvarop { $1 }
| qconop { $1 }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnnRArrow (glAA $1) []) }
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
-----------------------------------------------------------------------------
-- Backpack stuff
@@ -3662,7 +3662,7 @@ ntgtycon :: { LocatedN RdrName } -- A "general" qualified tycon, excluding unit
| '(#' bars '#)' {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))
(NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }
| '(' '->' ')' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
- (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }
+ (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }
| '[' ']' {% amsrn (sLL $1 $> $ listTyCon_RDR)
(NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }
@@ -3744,7 +3744,8 @@ otycon :: { LocatedN RdrName }
op :: { LocatedN RdrName } -- used in infix decls
: varop { $1 }
| conop { $1 }
- | '->' { sL1n $1 $ getRdrName unrestrictedFunTyCon }
+ | '->' {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)
+ (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }
varop :: { LocatedN RdrName }
: varsym { $1 }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -759,7 +759,10 @@ data NameAnn
}
-- | Used for @->@, as an identifier
| NameAnnRArrow {
+ nann_unicode :: Bool,
+ nann_mopen :: Maybe EpaLocation,
nann_name :: EpaLocation,
+ nann_mclose :: Maybe EpaLocation,
nann_trailing :: [TrailingAnn]
}
-- | Used for an item with a leading @'@. The annotation for
@@ -1436,8 +1439,8 @@ instance Outputable NameAnn where
= text "NameAnnBars" <+> ppr a <+> ppr o <+> ppr n <+> ppr b <+> ppr t
ppr (NameAnnOnly a o c t)
= text "NameAnnOnly" <+> ppr a <+> ppr o <+> ppr c <+> ppr t
- ppr (NameAnnRArrow n t)
- = text "NameAnnRArrow" <+> ppr n <+> ppr t
+ ppr (NameAnnRArrow u o n c t)
+ = text "NameAnnRArrow" <+> ppr u <+> ppr o <+> ppr n <+> ppr c <+> ppr t
ppr (NameAnnQuote q n t)
= text "NameAnnQuote" <+> ppr q <+> ppr n <+> ppr t
ppr (NameAnnTrailing t)
=====================================
libraries/base/Numeric.hs
=====================================
@@ -117,6 +117,14 @@ readHex = readP_to_S L.readHexP
-- | Reads an /unsigned/ 'RealFrac' value,
-- expressed in decimal scientific notation.
+--
+-- Note that this function takes time linear in the magnitude of its input
+-- which can scale exponentially with input size (e.g. @"1e100000000"@ is a
+-- very large number while having a very small textual form).
+-- For this reason, users should take care to avoid using this function on
+-- untrusted input. Users needing to parse floating point values
+-- (e.g. 'Float') are encouraged to instead use 'read', which does
+-- not suffer from this issue.
readFloat :: RealFrac a => ReadS a
readFloat = readP_to_S readFloatP
=====================================
libraries/parsec
=====================================
@@ -1 +1 @@
-Subproject commit ddcd0cbafe7637b15fda48f1c7cf735f3ccfd8c9
+Subproject commit 4cc55b481b2eaf0606235522a6a340c10ca8dbba
=====================================
rts/Continuation.c
=====================================
@@ -374,12 +374,12 @@ StgClosure *captureContinuationAndAbort(Capability *cap, StgTSO *tso, StgPromptT
// 1. We walk the stack to find the prompt frame to capture up to (if any).
//
// 2. If we successfully find a matching prompt, we proceed with the actual
- // by allocating space for the continuation, performing the necessary
- // copying, and unwinding the stack.
+ // capture by allocating space for the continuation, performing the
+ // necessary copying, and unwinding the stack.
//
// These variables are modified in Phase 1 to keep track of how far we had to
// walk before finding the prompt frame. Afterwards, Phase 2 consults them to
- // determine how to proceed with the actual capture.
+ // determine how to proceed.
StgWord total_words = 0;
bool in_first_chunk = true;
=====================================
rts/Exception.cmm
=====================================
@@ -393,16 +393,14 @@ stg_killMyself
* kind of return to the activation record underneath us on the stack.
*/
-#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,exceptions_blocked,handler) \
+#define CATCH_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,handler) \
w_ info_ptr, \
PROF_HDR_FIELDS(w_,p1,p2) \
- w_ exceptions_blocked, \
p_ handler
INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
- CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,
- exceptions_blocked,handler))
+ CATCH_FRAME_FIELDS(W_,P_,info_ptr, p1, p2,handler))
return (P_ ret)
{
return (ret);
@@ -411,12 +409,7 @@ INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
stg_catchzh ( P_ io, /* :: IO a */
P_ handler /* :: Exception -> IO a */ )
{
- W_ exceptions_blocked;
-
STK_CHK_GEN();
-
- exceptions_blocked =
- TO_W_(StgTSO_flags(CurrentTSO)) & (TSO_BLOCKEX | TSO_INTERRUPTIBLE);
TICK_CATCHF_PUSHED();
/* Apply R1 to the realworld token */
@@ -424,8 +417,7 @@ stg_catchzh ( P_ io, /* :: IO a */
TICK_SLOW_CALL_fast_v();
jump stg_ap_v_fast
- (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0,
- exceptions_blocked, handler))
+ (CATCH_FRAME_FIELDS(,,stg_catch_frame_info, CCCS, 0, handler))
(io);
}
@@ -599,26 +591,28 @@ retry_pop_stack:
frame = Sp;
if (frame_type == CATCH_FRAME)
{
+ // Note: if this branch is updated, there is a good chance that
+ // corresponding logic in `raiseAsync` must be updated to match!
+ // See Note [Apply the handler directly in raiseAsync] in RaiseAsync.c.
+
Sp = Sp + SIZEOF_StgCatchFrame;
- if ((StgCatchFrame_exceptions_blocked(frame) & TSO_BLOCKEX) == 0) {
+
+ W_ flags;
+ flags = TO_W_(StgTSO_flags(CurrentTSO));
+ if ((flags & TSO_BLOCKEX) == 0) {
Sp_adj(-1);
Sp(0) = stg_unmaskAsyncExceptionszh_ret_info;
}
/* Ensure that async exceptions are masked when running the handler.
- */
- StgTSO_flags(CurrentTSO) = %lobits32(
- TO_W_(StgTSO_flags(CurrentTSO)) | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
-
- /* The interruptible state is inherited from the context of the
+ *
+ * The interruptible state is inherited from the context of the
* catch frame, but note that TSO_INTERRUPTIBLE is only meaningful
* if TSO_BLOCKEX is set. (we got this wrong earlier, and #4988
* was a symptom of the bug).
*/
- if ((StgCatchFrame_exceptions_blocked(frame) &
- (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) == TSO_BLOCKEX) {
- StgTSO_flags(CurrentTSO) = %lobits32(
- TO_W_(StgTSO_flags(CurrentTSO)) & ~TSO_INTERRUPTIBLE);
+ if ((flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) {
+ StgTSO_flags(CurrentTSO) = %lobits32(flags | TSO_BLOCKEX | TSO_INTERRUPTIBLE);
}
}
else /* CATCH_STM_FRAME */
=====================================
rts/RaiseAsync.c
=====================================
@@ -951,44 +951,36 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
case CATCH_FRAME:
// If we find a CATCH_FRAME, and we've got an exception to raise,
- // then build the THUNK raise(exception), and leave it on
- // top of the CATCH_FRAME ready to enter.
- //
+ // then set up the top of the stack to apply the handler;
+ // see Note [Apply the handler directly in raiseAsync].
{
- StgCatchFrame *cf = (StgCatchFrame *)frame;
- StgThunk *raise;
-
if (exception == NULL) break;
- // we've got an exception to raise, so let's pass it to the
- // handler in this frame.
- //
- raise = (StgThunk *)allocate(cap,sizeofW(StgThunk)+1);
- TICK_ALLOC_SE_THK(sizeofW(StgThunk)+1,0);
- SET_HDR(raise,&stg_raise_info,cf->header.prof.ccs);
- raise->payload[0] = exception;
+ StgClosure *handler = ((StgCatchFrame *)frame)->handler;
- // throw away the stack from Sp up to the CATCH_FRAME.
- //
- sp = frame - 1;
-
- /* Ensure that async exceptions are blocked now, so we don't get
- * a surprise exception before we get around to executing the
- * handler.
- */
- tso->flags |= TSO_BLOCKEX;
- if ((cf->exceptions_blocked & TSO_INTERRUPTIBLE) == 0) {
- tso->flags &= ~TSO_INTERRUPTIBLE;
- } else {
- tso->flags |= TSO_INTERRUPTIBLE;
+ // Throw away the stack from Sp up to and including the CATCH_FRAME.
+ sp = frame + stack_frame_sizeW((StgClosure *)frame);
+
+ // Unmask async exceptions after running the handler, if necessary.
+ if ((tso->flags & TSO_BLOCKEX) == 0) {
+ sp--;
+ sp[0] = (W_)&stg_unmaskAsyncExceptionszh_ret_info;
}
- /* Put the newly-built THUNK on top of the stack, ready to execute
- * when the thread restarts.
- */
- sp[0] = (W_)raise;
- sp[-1] = (W_)&stg_enter_info;
- stack->sp = sp-1;
+ // Ensure that async exceptions are masked while running the handler;
+ // see Note [Apply the handler directly in raiseAsync].
+ if ((tso->flags & (TSO_BLOCKEX | TSO_INTERRUPTIBLE)) != TSO_BLOCKEX) {
+ tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+ }
+
+ // Set up the top of the stack to apply the handler.
+ sp -= 4;
+ sp[0] = (W_)&stg_enter_info;
+ sp[1] = (W_)handler;
+ sp[2] = (W_)&stg_ap_pv_info;
+ sp[3] = (W_)exception;
+
+ stack->sp = sp;
RELAXED_STORE(&tso->what_next, ThreadRunGHC);
goto done;
}
@@ -1080,6 +1072,15 @@ raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception,
};
default:
+ // see Note [Update async masking state on unwind] in Schedule.c
+ if (*frame == (W_)&stg_unmaskAsyncExceptionszh_ret_info) {
+ tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+ } else if (*frame == (W_)&stg_maskAsyncExceptionszh_ret_info) {
+ tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+ } else if (*frame == (W_)&stg_maskUninterruptiblezh_ret_info) {
+ tso->flags |= TSO_BLOCKEX;
+ tso->flags &= ~TSO_INTERRUPTIBLE;
+ }
break;
}
@@ -1098,3 +1099,26 @@ done:
return tso;
}
+
+/* Note [Apply the handler directly in raiseAsync]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we encounter a `catch#` frame while unwinding the stack due to an
+async exception, we need to set up the stack to resume execution by
+invoking the exception handler. One natural way to do it would be to
+simply place a `raise#` thunk on the top of the stack, ready to be
+entered. This would effectively convert the asynchronous exception to
+a synchronous one at a point where it’s known to be safe to do so.
+
+However, there is a danger to this strategy: if async exceptions are
+currently unmasked, it becomes possible for a second async exception
+to be delivered before we enter the application of `raise#`, which
+would result in the first exception being lost. The easiest way to
+prevent this race from happening is to have `raiseAsync` set up the
+stack to apply the handler directly, effectively emulating the
+behavior of `raise#`, as this allows exceptions to be preemptively
+masked before returning. This means `raiseAsync` must also push a
+frame to unmask async exceptions after the handler returns if
+necessary, just as `raise#` does.
+
+This strategy results in some logical duplication, but it is correct,
+and the duplicated logic is small enough to be acceptable. */
=====================================
rts/Schedule.c
=====================================
@@ -3019,19 +3019,6 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
// thunks which are currently under evaluation.
//
- // OLD COMMENT (we don't have MIN_UPD_SIZE now):
- // LDV profiling: stg_raise_info has THUNK as its closure
- // type. Since a THUNK takes at least MIN_UPD_SIZE words in its
- // payload, MIN_UPD_SIZE is more appropriate than 1. It seems that
- // 1 does not cause any problem unless profiling is performed.
- // However, when LDV profiling goes on, we need to linearly scan
- // small object pool, where raise_closure is stored, so we should
- // use MIN_UPD_SIZE.
- //
- // raise_closure = (StgClosure *)RET_STGCALL1(P_,allocate,
- // sizeofW(StgClosure)+1);
- //
-
//
// Walk up the stack, looking for the catch frame. On the way,
// we update any closures pointed to from update frames with the
@@ -3094,12 +3081,52 @@ raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception)
}
default:
+ // see Note [Update async masking state on unwind]
+ if (*p == (StgWord)&stg_unmaskAsyncExceptionszh_ret_info) {
+ tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);
+ } else if (*p == (StgWord)&stg_maskAsyncExceptionszh_ret_info) {
+ tso->flags |= TSO_BLOCKEX | TSO_INTERRUPTIBLE;
+ } else if (*p == (StgWord)&stg_maskUninterruptiblezh_ret_info) {
+ tso->flags |= TSO_BLOCKEX;
+ tso->flags &= ~TSO_INTERRUPTIBLE;
+ }
p = next;
continue;
}
}
}
+/* Note [Update async masking state on unwind]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When we raise an exception or capture a continuation, we unwind the
+stack by searching for an enclosing `catch#` or `prompt#` frame. If we
+unwind past frames intended to restore the async exception masking
+state, we must take care to reproduce their intended effect in order
+to ensure that async exceptions are properly unmasked or remasked.
+
+On paper, this seems as simple as updating `tso->flags` appropriately,
+but in fact there is one additional wrinkle: when async exceptions are
+*unmasked*, we must eagerly check for a pending async exception and
+raise it if necessary. This is not terribly involved, but it’s not
+trivial, either (see the definition of `stg_unmaskAsyncExceptionszh_ret`),
+so we’d prefer to avoid duplicating that logic in several places.
+
+Fortunately, when we’re unwinding the stack due to a raised exception,
+this detail is actually unimportant: `catch#` implicitly masks async
+exceptions while running the handler as we explicitly *don’t* want the
+thread to be interrupted before it has a chance to handle the
+exception. However, when capturing a continuation, we don’t have this
+luxury, so we take two different strategies:
+
+* When unwinding the stack due to a raised exception (synchonrous or
+ asynchronous), we just update `tso->flags` directly and take no
+ further action.
+
+* When unwinding the stack due to a continuation capture, we update
+ the masking state *indirectly* by pushing an appropriate frame onto
+ the stack before we return. This strategy is described at length
+ in Note [Continuations and async exception masking] in Continuation.c. */
+
/* -----------------------------------------------------------------------------
findRetryFrameHelper
=====================================
rts/include/rts/storage/Closures.h
=====================================
@@ -281,7 +281,6 @@ typedef struct {
// Closure types: CATCH_FRAME
typedef struct {
StgHeader header;
- StgWord exceptions_blocked;
StgClosure *handler;
} StgCatchFrame;
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -805,3 +805,9 @@ Test23465:
Test23887:
$(CHECK_PPR) $(LIBDIR) Test23887.hs
$(CHECK_EXACT) $(LIBDIR) Test23887.hs
+
+.PHONY: Test23885
+Test23885:
+ # ppr is not currently unicode aware
+ # $(CHECK_PPR) $(LIBDIR) Test23885.hs
+ $(CHECK_EXACT) $(LIBDIR) Test23885.hs
=====================================
testsuite/tests/printer/Test23885.hs
=====================================
@@ -0,0 +1,25 @@
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE FunctionalDependencies #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE UnicodeSyntax #-}
+module Test23885 where
+
+import Control.Monad (Monad(..), join, ap)
+import Data.Monoid (Monoid(..))
+import Data.Semigroup (Semigroup(..))
+
+class Monoidy to comp id m | m to → comp id where
+ munit :: id `to` m
+ mjoin :: (m `comp` m) `to` m
+
+newtype Sum a = Sum a deriving Show
+instance Num a ⇒ Monoidy (→) (,) () (Sum a) where
+ munit _ = Sum 0
+ mjoin (Sum x, Sum y) = Sum $ x + y
+
+data NT f g = NT { runNT :: ∀ α. f α → g α }
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -192,4 +192,5 @@ test('HsDocTy', [ignore_stderr, req_ppr_deps], makefile_test, ['HsDocTy'])
test('Test22765', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22765'])
test('Test22771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test22771'])
test('Test23465', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23465'])
-test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
\ No newline at end of file
+test('Test23887', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23887'])
+test('Test23885', [ignore_stderr, req_ppr_deps], makefile_test, ['Test23885'])
=====================================
testsuite/tests/rts/continuations/T23513.hs
=====================================
@@ -0,0 +1,36 @@
+-- This test checks that restoring a continuation that captures a CATCH frame
+-- properly adjusts the async exception masking state.
+
+import Control.Exception
+import Data.IORef
+
+import ContIO
+
+data E = E deriving (Show)
+instance Exception E
+
+printMaskingState :: IO ()
+printMaskingState = print =<< getMaskingState
+
+main :: IO ()
+main = do
+ tag <- newPromptTag
+ ref <- newIORef Nothing
+ mask_ $ prompt tag $
+ catch (control0 tag $ \k ->
+ writeIORef ref (Just k))
+ (\E -> printMaskingState)
+ Just k <- readIORef ref
+
+ let execute_test = do
+ k (printMaskingState *> throwIO E)
+ printMaskingState
+
+ putStrLn "initially unmasked:"
+ execute_test
+
+ putStrLn "\ninitially interruptibly masked:"
+ mask_ execute_test
+
+ putStrLn "\ninitially uninterruptibly masked:"
+ uninterruptibleMask_ execute_test
=====================================
testsuite/tests/rts/continuations/T23513.stdout
=====================================
@@ -0,0 +1,14 @@
+initially unmasked:
+Unmasked
+MaskedInterruptible
+Unmasked
+
+initially interruptibly masked:
+MaskedInterruptible
+MaskedInterruptible
+MaskedInterruptible
+
+initially uninterruptibly masked:
+MaskedUninterruptible
+MaskedUninterruptible
+MaskedUninterruptible
=====================================
testsuite/tests/rts/continuations/all.T
=====================================
@@ -7,3 +7,5 @@ test('cont_exn_masking', [extra_files(['ContIO.hs'])], multimod_compile_and_run,
test('cont_missing_prompt_err', [extra_files(['ContIO.hs']), exit_code(1)], multimod_compile_and_run, ['cont_missing_prompt_err', ''])
test('cont_nondet_handler', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_nondet_handler', ''])
test('cont_stack_overflow', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['cont_stack_overflow', '-with-rtsopts "-ki1k -kc2k -kb256"'])
+
+test('T23513', [extra_files(['ContIO.hs'])], multimod_compile_and_run, ['T23513', ''])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -4107,7 +4107,7 @@ instance ExactPrint (LocatedN RdrName) where
NameAnn a o l c t -> do
mn <- markName a o (Just (l,n)) c
case mn of
- (o', (Just (l',_n)), c') -> do -- (o', (Just (l',n')), c')
+ (o', (Just (l',_n)), c') -> do
t' <- markTrailing t
return (NameAnn a o' l' c' t')
_ -> error "ExactPrint (LocatedN RdrName)"
@@ -4129,10 +4129,23 @@ instance ExactPrint (LocatedN RdrName) where
(o',_,c') <- markName a o Nothing c
t' <- markTrailing t
return (NameAnnOnly a o' c' t')
- NameAnnRArrow nl t -> do
- (AddEpAnn _ nl') <- markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ NameAnnRArrow unicode o nl c t -> do
+ o' <- case o of
+ Just o0 -> do
+ (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn AnnOpenP o0)
+ return (Just o')
+ Nothing -> return Nothing
+ (AddEpAnn _ nl') <-
+ if unicode
+ then markKwC NoCaptureComments (AddEpAnn AnnRarrowU nl)
+ else markKwC NoCaptureComments (AddEpAnn AnnRarrow nl)
+ c' <- case c of
+ Just c0 -> do
+ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn AnnCloseP c0)
+ return (Just c')
+ Nothing -> return Nothing
t' <- markTrailing t
- return (NameAnnRArrow nl' t')
+ return (NameAnnRArrow unicode o' nl' c' t')
NameAnnQuote q name t -> do
debugM $ "NameAnnQuote"
(AddEpAnn _ q') <- markKwC NoCaptureComments (AddEpAnn AnnSimpleQuote q)
=====================================
utils/deriveConstants/Main.hs
=====================================
@@ -484,7 +484,6 @@ wanteds os = concat
,closureField Both "StgOrigThunkInfoFrame" "info_ptr"
,closureField C "StgCatchFrame" "handler"
- ,closureField C "StgCatchFrame" "exceptions_blocked"
,structSize C "StgRetFun"
,fieldOffset C "StgRetFun" "size"
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 1130973f07aecc37a37943f4b1cc529aabd15e61
+Subproject commit d073163aacdb321c4020d575fc417a9b2368567a
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ab181253996f6d5cab30d77d0ccf85474a39279...751f109d5594308ac41a8ee9d2e910b0aaaee47c
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ab181253996f6d5cab30d77d0ccf85474a39279...751f109d5594308ac41a8ee9d2e910b0aaaee47c
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230918/cf5d7096/attachment-0001.html>
More information about the ghc-commits
mailing list