[Git][ghc/ghc][wip/T22859] 3 commits: Fix sharing of 'IfaceTyConInfo' during core to iface type translation

Teo Camarasu (@teo) gitlab at gitlab.haskell.org
Thu Mar 21 16:28:36 UTC 2024



Teo Camarasu pushed to branch wip/T22859 at Glasgow Haskell Compiler / GHC


Commits:
73be65ab by Fendor at 2024-03-19T01:42:53-04:00
Fix sharing of 'IfaceTyConInfo' during core to iface type translation

During heap analysis, we noticed that during generation of
'mi_extra_decls' we have lots of duplicates for the instances:

* `IfaceTyConInfo NotPromoted IfaceNormalTyCon`
* `IfaceTyConInfo IsPromoted IfaceNormalTyCon`

which should be shared instead of duplicated. This duplication increased
the number of live bytes by around 200MB while loading the agda codebase
into GHCi.

These instances are created during `CoreToIface` translation, in
particular `toIfaceTyCon`.

The generated core looks like:

    toIfaceTyCon
      = \ tc_sjJw ->
          case $wtoIfaceTyCon tc_sjJw of
          { (# ww_sjJz, ww1_sjNL, ww2_sjNM #) ->
          IfaceTyCon ww_sjJz (IfaceTyConInfo ww1_sjNL ww2_sjNM)
          }

whichs removes causes the sharing to work propery.

Adding explicit sharing, with NOINLINE annotations, changes the core to:

    toIfaceTyCon
      = \ tc_sjJq ->
          case $wtoIfaceTyCon tc_sjJq of { (# ww_sjNB, ww1_sjNC #) ->
          IfaceTyCon ww_sjNB ww1_sjNC
          }

which looks much more like sharing is happening.
We confirmed via ghc-debug that all duplications were eliminated and the
number of live bytes are noticeably reduced.

- - - - -
bd8209eb by Alan Zimmerman at 2024-03-19T01:43:28-04:00
EPA: Address more 9.10.1-alpha1 regressions from recent changes

Closes #24533
Hopefully for good this time

- - - - -
b76643e0 by Teo Camarasu at 2024-03-21T16:28:06+00:00
Implement user-defined allocation limit handlers

Resolves #22859

- - - - -


29 changed files:

- compiler/GHC/Builtin/primops.txt.pp
- compiler/GHC/Iface/Type.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/StgToCmm/Prim.hs
- compiler/GHC/StgToJS/Prim.hs
- libraries/ghc-experimental/ghc-experimental.cabal
- + libraries/ghc-experimental/src/System/Mem/Experimental.hs
- libraries/ghc-internal/ghc-internal.cabal
- + libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
- rts/Prelude.h
- rts/PrimOps.cmm
- rts/RtsSymbols.c
- rts/Schedule.c
- rts/external-symbols.list.in
- rts/include/rts/storage/GC.h
- rts/include/rts/storage/TSO.h
- rts/include/stg/MiscClosures.h
- 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
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/interface-stability/ghc-experimental-exports.stdout
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- testsuite/tests/printer/Test24533.hs
- testsuite/tests/printer/Test24533.stdout
- + testsuite/tests/rts/T22859.hs
- + testsuite/tests/rts/T22859.stderr
- testsuite/tests/rts/all.T


Changes:

=====================================
compiler/GHC/Builtin/primops.txt.pp
=====================================
@@ -3952,6 +3952,15 @@ primop  SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
    effect = ReadWriteEffect
    out_of_line      = True
 
+primop  SetOtherThreadAllocationCounter "setOtherThreadAllocationCounter#" GenPrimOp
+   Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
+   { Sets the allocation counter for the another thread to the given value.
+     This doesn't take allocations into the current nursery chunk into account.
+     Therefore it is only accurate if the other thread is not currently running. }
+   with
+   effect = ReadWriteEffect
+   out_of_line      = True
+
 primtype StackSnapshot#
    { Haskell representation of a @StgStack*@ that was created (cloned)
      with a function in "GHC.Stack.CloneStack". Please check the


=====================================
compiler/GHC/Iface/Type.hs
=====================================
@@ -361,12 +361,51 @@ data IfaceTyConInfo   -- Used only to guide pretty-printing
                    , ifaceTyConSort       :: IfaceTyConSort }
     deriving (Eq)
 
--- This smart constructor allows sharing of the two most common
--- cases. See #19194
+-- | This smart constructor allows sharing of the two most common
+-- cases. See Note [Sharing IfaceTyConInfo]
 mkIfaceTyConInfo :: PromotionFlag -> IfaceTyConSort -> IfaceTyConInfo
-mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = IfaceTyConInfo IsPromoted  IfaceNormalTyCon
-mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = IfaceTyConInfo NotPromoted IfaceNormalTyCon
-mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom        sort
+mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = promotedNormalTyConInfo
+mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
+mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom sort
+
+{-# NOINLINE promotedNormalTyConInfo #-}
+-- | See Note [Sharing IfaceTyConInfo]
+promotedNormalTyConInfo :: IfaceTyConInfo
+promotedNormalTyConInfo = IfaceTyConInfo IsPromoted IfaceNormalTyCon
+
+{-# NOINLINE notPromotedNormalTyConInfo #-}
+-- | See Note [Sharing IfaceTyConInfo]
+notPromotedNormalTyConInfo :: IfaceTyConInfo
+notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+
+{-
+Note [Sharing IfaceTyConInfo]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+'IfaceTyConInfo' occurs an awful lot in 'ModIface', see #19194 for an example.
+But almost all of them are
+
+   IfaceTyConInfo IsPromoted IfaceNormalTyCon
+   IfaceTyConInfo NotPromoted IfaceNormalTyCon.
+
+The smart constructor `mkIfaceTyConInfo` arranges to share these instances,
+thus:
+
+  promotedNormalTyConInfo    = IfaceTyConInfo IsPromoted  IfaceNormalTyCon
+  notPromotedNormalTyConInfo = IfaceTyConInfo NotPromoted IfaceNormalTyCon
+
+  mkIfaceTyConInfo IsPromoted  IfaceNormalTyCon = promotedNormalTyConInfo
+  mkIfaceTyConInfo NotPromoted IfaceNormalTyCon = notPromotedNormalTyConInfo
+  mkIfaceTyConInfo prom        sort             = IfaceTyConInfo prom sort
+
+But ALAS, the (nested) CPR transform can lose this sharing, completely
+negating the effect of `mkIfaceTyConInfo`: see #24530 and #19326.
+
+Sticking-plaster solution: add a NOINLINE pragma to those top-level constants.
+When we fix the CPR bug we can remove the NOINLINE pragmas.
+
+This one change leads to an 15% reduction in residency for GHC when embedding
+'mi_extra_decls': see !12222.
+-}
 
 data IfaceMCoercion
   = IfaceMRefl


=====================================
compiler/GHC/Parser.y
=====================================
@@ -1237,12 +1237,12 @@ topdecl_cs : topdecl {% commentsPA $1 }
 
 -----------------------------------------------------------------------------
 topdecl :: { LHsDecl GhcPs }
-        : cl_decl                               { sL1a $1 (TyClD noExtField (unLoc $1)) }
-        | ty_decl                               { sL1a $1 (TyClD noExtField (unLoc $1)) }
-        | standalone_kind_sig                   { sL1a $1 (KindSigD noExtField (unLoc $1)) }
-        | inst_decl                             { sL1a $1 (InstD noExtField (unLoc $1)) }
-        | stand_alone_deriving                  { sL1a $1 (DerivD noExtField (unLoc $1)) }
-        | role_annot                            { sL1a $1 (RoleAnnotD noExtField (unLoc $1)) }
+        : cl_decl                               { L (getLoc $1) (TyClD noExtField (unLoc $1)) }
+        | ty_decl                               { L (getLoc $1) (TyClD noExtField (unLoc $1)) }
+        | standalone_kind_sig                   { L (getLoc $1) (KindSigD noExtField (unLoc $1)) }
+        | inst_decl                             { L (getLoc $1) (InstD noExtField (unLoc $1)) }
+        | stand_alone_deriving                  { L (getLoc $1) (DerivD noExtField (unLoc $1)) }
+        | role_annot                            { L (getLoc $1) (RoleAnnotD noExtField (unLoc $1)) }
         | 'default' '(' comma_types0 ')'        {% amsA' (sLL $1 $>
                                                     (DefD noExtField (DefaultDecl [mj AnnDefault $1,mop $2,mcp $4] $3))) }
         | 'foreign' fdecl                       {% amsA' (sLL $1 $> ((snd $ unLoc $2) (mj AnnForeign $1:(fst $ unLoc $2)))) }


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -943,11 +943,13 @@ checkTyVars pp_what equals_or_where tc tparms
         -- Keep around an action for adjusting the annotations of extra parens
     chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs
               -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)
-    chkParens ops cps bvis (L l (HsParTy _ ty))
+    chkParens ops cps bvis (L l (HsParTy _ (L lt  ty)))
       = let
           (o,c) = mkParensEpAnn (realSrcSpan $ locA l)
+          lcs = epAnnComments l
+          lt' = setCommentsEpAnn lt lcs
         in
-          chkParens (o:ops) (c:cps) bvis ty
+          chkParens (o:ops) (c:cps) bvis (L lt' ty)
     chkParens ops cps bvis ty = chk ops cps bvis ty
 
         -- Check that the name space is correct!


=====================================
compiler/GHC/StgToCmm/Prim.hs
=====================================
@@ -1746,6 +1746,7 @@ emitPrimOp cfg primop =
   TraceEventBinaryOp -> alwaysExternal
   TraceMarkerOp -> alwaysExternal
   SetThreadAllocationCounter -> alwaysExternal
+  SetOtherThreadAllocationCounter -> alwaysExternal
   KeepAliveOp -> alwaysExternal
   CastWord32ToFloatOp -> alwaysExternal
   CastWord64ToDoubleOp -> alwaysExternal


=====================================
compiler/GHC/StgToJS/Prim.hs
=====================================
@@ -1167,6 +1167,7 @@ genPrim prof bound ty op = case op of
   WhereFromOp                       -> unhandledPrimop op -- should be easily implementable with o.f.n
 
   SetThreadAllocationCounter        -> unhandledPrimop op
+  SetOtherThreadAllocationCounter   -> unhandledPrimop op
 
 ------------------------------- Vector -----------------------------------------
 -- For now, vectors are unsupported on the JS backend. Simply put, they do not


=====================================
libraries/ghc-experimental/ghc-experimental.cabal
=====================================
@@ -27,6 +27,7 @@ library
       Data.Tuple.Experimental
       Data.Sum.Experimental
       Prelude.Experimental
+      System.Mem.Experimental
     if arch(wasm32)
         exposed-modules:  GHC.Wasm.Prim
     other-extensions:


=====================================
libraries/ghc-experimental/src/System/Mem/Experimental.hs
=====================================
@@ -0,0 +1,10 @@
+module System.Mem.Experimental
+  ( setGlobalAllocationLimitHandler
+  , AllocationLimitKillBehaviour(..)
+  , getAllocationCounterFor
+  , setAllocationCounterFor
+  , enableAllocationLimitFor
+  , disableAllocationLimitFor
+  )
+  where
+import GHC.Internal.AllocationLimitHandler


=====================================
libraries/ghc-internal/ghc-internal.cabal
=====================================
@@ -91,6 +91,7 @@ Library
         ghc-bignum >= 1.0 && < 2.0
 
     exposed-modules:
+        GHC.Internal.AllocationLimitHandler
         GHC.Internal.ClosureTypes
         GHC.Internal.Control.Arrow
         GHC.Internal.Control.Category


=====================================
libraries/ghc-internal/src/GHC/Internal/AllocationLimitHandler.hs
=====================================
@@ -0,0 +1,106 @@
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+{-# LANGUAGE GHCForeignImportPrim #-}
+{-# OPTIONS_HADDOCK not-home #-}
+module GHC.Internal.AllocationLimitHandler
+  ( runAllocationLimitHandler
+  , setGlobalAllocationLimitHandler
+  , AllocationLimitKillBehaviour(..)
+  , getAllocationCounterFor
+  , setAllocationCounterFor
+  , enableAllocationLimitFor
+  , disableAllocationLimitFor
+  )
+  where
+import GHC.Internal.Base
+import GHC.Internal.Conc.Sync (ThreadId(..))
+import GHC.Internal.Data.IORef (IORef, readIORef, writeIORef, newIORef)
+import GHC.Internal.Foreign.C.Types
+import GHC.Internal.IO (unsafePerformIO)
+import GHC.Internal.Int (Int64(..))
+
+
+{-# NOINLINE allocationLimitHandler #-}
+allocationLimitHandler :: IORef (ThreadId -> IO ())
+allocationLimitHandler = unsafePerformIO (newIORef defaultHandler)
+
+defaultHandler :: ThreadId -> IO ()
+defaultHandler _ = pure ()
+
+foreign import ccall "setAllocLimitKill" setAllocLimitKill :: CBool -> CBool -> IO ()
+
+runAllocationLimitHandler :: ThreadId# -> IO ()
+runAllocationLimitHandler tid = do
+  hook <- getAllocationLimitHandler
+  hook $ ThreadId tid
+
+getAllocationLimitHandler :: IO (ThreadId -> IO ())
+getAllocationLimitHandler = readIORef allocationLimitHandler
+
+data AllocationLimitKillBehaviour =
+  KillOnAllocationLimit
+  -- ^ Throw a @AllocationLimitExceeded@ async exception to the thread when the
+  -- allocation limit is exceeded.
+  | DontKillOnAllocationLimit
+  -- ^ Do not throw an exception when the allocation limit is exceeded.
+
+-- | Define the behaviour for handling allocation limits.
+-- By default we throw a @AllocationLimitExceeded@ async exception to the thread.
+-- This can be controlled using @AllocationLimitKillBehaviour at .
+--
+-- We can also run a user-specified handler, which can be done in addition to
+-- or in place of the exception.
+-- This allows for instance logging on the allocation limit being exceeded,
+-- or dynamically determining whether to terminate the thread.
+-- The handler is not guaranteed to run before the thread is terminated or restarted.
+--
+-- Note: that if you don't terminate the thread, then the allocation limit gets
+-- removed.
+-- If you wish to keep the allocation limit you will have to reset it using
+-- @setAllocationCounter@ and @enableAllocationLimit at .
+setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> Maybe (ThreadId -> IO ()) -> IO ()
+setGlobalAllocationLimitHandler killBehaviour mHandler = do
+  shouldRunHandler <- case mHandler of
+    Just hook -> do
+      writeIORef allocationLimitHandler hook
+      pure 1
+    Nothing -> do
+      writeIORef allocationLimitHandler defaultHandler
+      pure 0
+  let shouldKill =
+        case killBehaviour of
+          KillOnAllocationLimit -> 1
+          DontKillOnAllocationLimit -> 0
+  setAllocLimitKill shouldKill shouldRunHandler
+
+-- | Retrieves the allocation counter for the another thread.
+foreign import prim "stg_getOtherThreadAllocationCounterzh" getOtherThreadAllocationCounter#
+  :: ThreadId#
+  -> State# RealWorld
+  -> (# State# RealWorld, Int64# #)
+
+getAllocationCounterFor :: ThreadId -> IO Int64
+getAllocationCounterFor (ThreadId t#) = IO $ \s ->
+  case getOtherThreadAllocationCounter# t# s of (# s', i# #)  -> (# s', I64# i# #)
+
+setAllocationCounterFor :: Int64 -> ThreadId -> IO ()
+setAllocationCounterFor (I64# i#) (ThreadId t#) = IO $ \s ->
+  case setOtherThreadAllocationCounter# i# t# s of s' -> (# s', () #)
+
+
+-- | Enable allocation limit processing the thread @t at .
+enableAllocationLimitFor :: ThreadId -> IO ()
+enableAllocationLimitFor (ThreadId t) = do
+  rts_enableThreadAllocationLimit t
+
+-- | Disable allocation limit processing the thread @t at .
+disableAllocationLimitFor :: ThreadId -> IO ()
+disableAllocationLimitFor (ThreadId t) = do
+  rts_disableThreadAllocationLimit t
+
+foreign import ccall unsafe "rts_enableThreadAllocationLimit"
+  rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
+
+foreign import ccall unsafe "rts_disableThreadAllocationLimit"
+  rts_disableThreadAllocationLimit :: ThreadId# -> IO ()


=====================================
rts/Prelude.h
=====================================
@@ -67,6 +67,7 @@ PRELUDE_CLOSURE(ghczminternal_GHCziInternalziEventziWindows_processRemoteComplet
 
 PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure);
 PRELUDE_CLOSURE(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure);
+PRELUDE_CLOSURE(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure);
 
 PRELUDE_INFO(ghczmprim_GHCziCString_unpackCStringzh_info);
 PRELUDE_INFO(ghczmprim_GHCziTypes_Czh_con_info);
@@ -102,6 +103,7 @@ PRELUDE_INFO(ghczminternal_GHCziInternalziStable_StablePtr_con_info);
 #if defined(mingw32_HOST_OS)
 #define processRemoteCompletion_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziEventziWindows_processRemoteCompletion_closure)
 #endif
+#define runAllocationLimitHandler_closure DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure)
 
 #define flushStdHandles_closure   DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure)
 #define runMainIO_closure   DLL_IMPORT_DATA_REF(ghczminternal_GHCziInternalziTopHandler_runMainIO_closure)


=====================================
rts/PrimOps.cmm
=====================================
@@ -2923,6 +2923,11 @@ stg_getThreadAllocationCounterzh ()
     return (StgTSO_alloc_limit(CurrentTSO) - TO_I64(offset));
 }
 
+stg_getOtherThreadAllocationCounterzh ( gcptr t )
+{
+    return (StgTSO_alloc_limit(t));
+}
+
 stg_setThreadAllocationCounterzh ( I64 counter )
 {
     // Allocation in the current block will be subtracted by
@@ -2935,6 +2940,12 @@ stg_setThreadAllocationCounterzh ( I64 counter )
     return ();
 }
 
+stg_setOtherThreadAllocationCounterzh ( I64 counter, gcptr t )
+{
+    StgTSO_alloc_limit(t) = counter;
+    return ();
+}
+
 
 #define KEEP_ALIVE_FRAME_FIELDS(w_,p_,info_ptr,p1,p2,c)   \
   w_ info_ptr,                                            \


=====================================
rts/RtsSymbols.c
=====================================
@@ -914,7 +914,9 @@ extern char **environ;
       SymI_HasDataProto(stg_traceMarkerzh)                                  \
       SymI_HasDataProto(stg_traceBinaryEventzh)                             \
       SymI_HasDataProto(stg_getThreadAllocationCounterzh)                   \
+      SymI_HasDataProto(stg_getOtherThreadAllocationCounterzh)              \
       SymI_HasDataProto(stg_setThreadAllocationCounterzh)                   \
+      SymI_HasDataProto(stg_setOtherThreadAllocationCounterzh)              \
       SymI_HasProto(getMonotonicNSec)                                   \
       SymI_HasProto(lockFile)                                           \
       SymI_HasProto(unlockFile)                                         \


=====================================
rts/Schedule.c
=====================================
@@ -41,6 +41,7 @@
 #include "Threads.h"
 #include "Timer.h"
 #include "ThreadPaused.h"
+#include "ThreadLabels.h"
 #include "Messages.h"
 #include "StablePtr.h"
 #include "StableName.h"
@@ -94,6 +95,10 @@ StgWord recent_activity = ACTIVITY_YES;
  */
 StgWord sched_state = SCHED_RUNNING;
 
+
+bool allocLimitKill = true;
+bool allocLimitRunHook = false;
+
 /*
  * This mutex protects most of the global scheduler data in
  * the THREADED_RTS runtime.
@@ -1113,19 +1118,36 @@ schedulePostRunThread (Capability *cap, StgTSO *t)
         }
     }
 
-    //
-    // If the current thread's allocation limit has run out, send it
-    // the AllocationLimitExceeded exception.
+    // Handle the current thread's allocation limit running out,
 
     if (PK_Int64((W_*)&(t->alloc_limit)) < 0 && (t->flags & TSO_ALLOC_LIMIT)) {
-        // Use a throwToSelf rather than a throwToSingleThreaded, because
-        // it correctly handles the case where the thread is currently
-        // inside mask.  Also the thread might be blocked (e.g. on an
-        // MVar), and throwToSingleThreaded doesn't unblock it
-        // correctly in that case.
-        throwToSelf(cap, t, allocationLimitExceeded_closure);
-        ASSIGN_Int64((W_*)&(t->alloc_limit),
-                     (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+        if(allocLimitKill) {
+          // Throw the AllocationLimitExceeded exception.
+          // Use a throwToSelf rather than a throwToSingleThreaded, because
+          // it correctly handles the case where the thread is currently
+          // inside mask.  Also the thread might be blocked (e.g. on an
+          // MVar), and throwToSingleThreaded doesn't unblock it
+          // correctly in that case.
+          throwToSelf(cap, t, allocationLimitExceeded_closure);
+          ASSIGN_Int64((W_*)&(t->alloc_limit),
+                      (StgInt64)RtsFlags.GcFlags.allocLimitGrace * BLOCK_SIZE);
+        } else {
+          // If we aren't killing the thread, we must disable the limit
+          // otherwise we will immediatelly retrigger it.
+          // User defined handlers should re-enable it if wanted.
+          t->flags = t->flags & ~TSO_ALLOC_LIMIT;
+        }
+
+        if(allocLimitRunHook)
+        {
+          // Create a thread to run the allocation limit handler.
+          StgClosure* c = rts_apply(cap, runAllocationLimitHandler_closure, (StgClosure*)t);
+          StgTSO* hookThread = createIOThread(cap, RtsFlags.GcFlags.initialStkSize, c);
+          setThreadLabel(cap, hookThread, "allocation limit handler thread");
+          // Schedule the handler to be run immediatelly.
+          pushOnRunQueue(cap, hookThread);
+        }
+
     }
 
   /* some statistics gathering in the parallel case */
@@ -3327,3 +3349,9 @@ resurrectThreads (StgTSO *threads)
         }
     }
 }
+
+void setAllocLimitKill(bool shouldKill, bool shouldHook)
+{
+   allocLimitKill = shouldKill;
+   allocLimitRunHook = shouldHook;
+}


=====================================
rts/external-symbols.list.in
=====================================
@@ -38,6 +38,7 @@ ghczminternal_GHCziInternalziConcziIO_ioManagerCapabilitiesChanged_closure
 ghczminternal_GHCziInternalziConcziSignal_runHandlersPtr_closure
 ghczminternal_GHCziInternalziTopHandler_flushStdHandles_closure
 ghczminternal_GHCziInternalziTopHandler_runMainIO_closure
+ghczminternal_GHCziInternalziAllocationLimitHandler_runAllocationLimitHandler_closure
 ghczmprim_GHCziTypes_Czh_con_info
 ghczmprim_GHCziTypes_Izh_con_info
 ghczmprim_GHCziTypes_Fzh_con_info


=====================================
rts/include/rts/storage/GC.h
=====================================
@@ -209,6 +209,10 @@ void flushExec(W_ len, AdjustorExecutable exec_addr);
 // Used by GC checks in external .cmm code:
 extern W_ large_alloc_lim;
 
+// Should triggering an allocation limit kill the thread
+// and should we run a user-defined hook when it is triggered.
+void setAllocLimitKill(bool, bool);
+
 /* -----------------------------------------------------------------------------
    Performing Garbage Collection
    -------------------------------------------------------------------------- */


=====================================
rts/include/rts/storage/TSO.h
=====================================
@@ -157,9 +157,10 @@ typedef struct StgTSO_ {
     /*
      * The allocation limit for this thread, which is updated as the
      * thread allocates.  If the value drops below zero, and
-     * TSO_ALLOC_LIMIT is set in flags, we raise an exception in the
-     * thread, and give the thread a little more space to handle the
-     * exception before we raise the exception again.
+     * TSO_ALLOC_LIMIT is set in flags, then a handler is triggerd.
+     * Either we raise an exception in the thread, and give the thread
+     * a little more space to handle the exception before we raise the
+     * exception again; or we run a user defined handler.
      *
      * This is an integer, because we might update it in a place where
      * it isn't convenient to raise the exception, so we want it to


=====================================
rts/include/stg/MiscClosures.h
=====================================
@@ -588,7 +588,9 @@ RTS_FUN_DECL(stg_traceEventzh);
 RTS_FUN_DECL(stg_traceBinaryEventzh);
 RTS_FUN_DECL(stg_traceMarkerzh);
 RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_getOtherThreadAllocationCounterzh);
 RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
+RTS_FUN_DECL(stg_setOtherThreadAllocationCounterzh);
 
 RTS_FUN_DECL(stg_castWord64ToDoublezh);
 RTS_FUN_DECL(stg_castDoubleToWord64zh);


=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -4585,6 +4585,7 @@ module GHC.Base where
   sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#
@@ -6689,6 +6690,7 @@ module GHC.Exts where
   seq# :: forall a d. a -> State# d -> (# State# d, a #)
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#


=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -4585,6 +4585,7 @@ module GHC.Base where
   sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#
@@ -6658,6 +6659,7 @@ module GHC.Exts where
   seq# :: forall a d. a -> State# d -> (# State# d, a #)
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#


=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -4588,6 +4588,7 @@ module GHC.Base where
   sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#
@@ -6838,6 +6839,7 @@ module GHC.Exts where
   seq# :: forall a d. a -> State# d -> (# State# d, a #)
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#


=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -4585,6 +4585,7 @@ module GHC.Base where
   sequence :: forall (m :: * -> *) a. Monad m => [m a] -> m [a]
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#
@@ -6689,6 +6690,7 @@ module GHC.Exts where
   seq# :: forall a d. a -> State# d -> (# State# d, a #)
   setAddrRange# :: Addr# -> Int# -> Int# -> State# RealWorld -> State# RealWorld
   setByteArray# :: forall d. MutableByteArray# d -> Int# -> Int# -> Int# -> State# d -> State# d
+  setOtherThreadAllocationCounter# :: Int64# -> ThreadId# -> State# RealWorld -> State# RealWorld
   setThreadAllocationCounter# :: Int64# -> State# RealWorld -> State# RealWorld
   shiftL# :: Word# -> Int# -> Word#
   shiftRL# :: Word# -> Int# -> Word#


=====================================
testsuite/tests/interface-stability/ghc-experimental-exports.stdout
=====================================
@@ -8638,6 +8638,16 @@ module Prelude.Experimental where
   data Unit# = ...
   getSolo :: forall a. Solo a -> a
 
+module System.Mem.Experimental where
+  -- Safety: None
+  type AllocationLimitKillBehaviour :: *
+  data AllocationLimitKillBehaviour = KillOnAllocationLimit | DontKillOnAllocationLimit
+  disableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+  enableAllocationLimitFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+  getAllocationCounterFor :: GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO GHC.Internal.Int.Int64
+  setAllocationCounterFor :: GHC.Internal.Int.Int64 -> GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()
+  setGlobalAllocationLimitHandler :: AllocationLimitKillBehaviour -> GHC.Internal.Maybe.Maybe (GHC.Internal.Conc.Sync.ThreadId -> GHC.Types.IO ()) -> GHC.Types.IO ()
+
 
 -- Instances:
 instance GHC.Classes.Eq GHC.Types.Bool -- Defined in ‘GHC.Classes’


=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -212,7 +212,10 @@
              (EpaComments
               []))
             (HsTupleTy
-             (AnnParen AnnParens (EpaSpan { DumpSemis.hs:9:11 }) (EpaSpan { DumpSemis.hs:9:12 }))
+             (AnnParen
+              AnnParens
+              (EpaSpan { DumpSemis.hs:9:11 })
+              (EpaSpan { DumpSemis.hs:9:12 }))
              (HsBoxedOrConstraintTuple)
              []))))))))))
   ,(L
@@ -498,7 +501,10 @@
              (EpaComments
               []))
             (HsTupleTy
-             (AnnParen AnnParens (EpaSpan { DumpSemis.hs:14:11 }) (EpaSpan { DumpSemis.hs:14:12 }))
+             (AnnParen
+              AnnParens
+              (EpaSpan { DumpSemis.hs:14:11 })
+              (EpaSpan { DumpSemis.hs:14:12 }))
              (HsBoxedOrConstraintTuple)
              []))))))))))
   ,(L
@@ -747,7 +753,10 @@
              (EpaComments
               []))
             (HsTupleTy
-             (AnnParen AnnParens (EpaSpan { DumpSemis.hs:21:11 }) (EpaSpan { DumpSemis.hs:21:12 }))
+             (AnnParen
+              AnnParens
+              (EpaSpan { DumpSemis.hs:21:11 })
+              (EpaSpan { DumpSemis.hs:21:12 }))
              (HsBoxedOrConstraintTuple)
              []))))))))))
   ,(L


=====================================
testsuite/tests/printer/Test24533.hs
=====================================
@@ -6,3 +6,9 @@ instance
     Read b
   ) =>
   Read (a, b)
+
+class Foo (a :: Type {- Weird -})
+
+instance Eq Foo where
+  -- Weird
+  Foo == Foo = True


=====================================
testsuite/tests/printer/Test24533.stdout
=====================================
@@ -13,8 +13,8 @@
      []
      (Just
       ((,)
-       { Test24533.hs:9:1 }
-       { Test24533.hs:8:13 })))
+       { Test24533.hs:15:1 }
+       { Test24533.hs:14:16-19 })))
     (EpaCommentsBalanced
      [(L
        (EpaSpan
@@ -273,6 +273,323 @@
        []
        []
        []
+       (Nothing)))))
+  ,(L
+    (EpAnn
+     (EpaSpan { Test24533.hs:10:1-33 })
+     (AnnListItem
+      [])
+     (EpaComments
+      []))
+    (TyClD
+     (NoExtField)
+     (ClassDecl
+      ((,,)
+       [(AddEpAnn AnnClass (EpaSpan { Test24533.hs:10:1-5 }))]
+       (EpNoLayout)
+       (NoAnnSortKey))
+      (Nothing)
+      (L
+       (EpAnn
+        (EpaSpan { Test24533.hs:10:7-9 })
+        (NameAnnTrailing
+         [])
+        (EpaComments
+         []))
+       (Unqual
+        {OccName: Foo}))
+      (HsQTvs
+       (NoExtField)
+       [(L
+         (EpAnn
+          (EpaSpan { Test24533.hs:10:11-33 })
+          (AnnListItem
+           [])
+          (EpaComments
+           [(L
+             (EpaSpan
+              { Test24533.hs:10:22-32 })
+             (EpaComment
+              (EpaBlockComment
+               "{- Weird -}")
+              { Test24533.hs:10:17-20 }))]))
+         (KindedTyVar
+          [(AddEpAnn AnnOpenP (EpaSpan { Test24533.hs:10:11 }))
+          ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.hs:10:33 }))
+          ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.hs:10:14-15 }))]
+          (HsBndrRequired
+           (NoExtField))
+          (L
+           (EpAnn
+            (EpaSpan { Test24533.hs:10:12 })
+            (NameAnnTrailing
+             [])
+            (EpaComments
+             []))
+           (Unqual
+            {OccName: a}))
+          (L
+           (EpAnn
+            (EpaSpan { Test24533.hs:10:17-20 })
+            (AnnListItem
+             [])
+            (EpaComments
+             []))
+           (HsTyVar
+            []
+            (NotPromoted)
+            (L
+             (EpAnn
+              (EpaSpan { Test24533.hs:10:17-20 })
+              (NameAnnTrailing
+               [])
+              (EpaComments
+               []))
+             (Unqual
+              {OccName: Type}))))))])
+      (Prefix)
+      []
+      []
+      {Bag(LocatedA (HsBind GhcPs)):
+       []}
+      []
+      []
+      [])))
+  ,(L
+    (EpAnn
+     (EpaSpan { Test24533.hs:(12,1)-(14,19) })
+     (AnnListItem
+      [])
+     (EpaComments
+      [(L
+        (EpaSpan
+         { Test24533.hs:13:3-10 })
+        (EpaComment
+         (EpaLineComment
+          "-- Weird")
+         { Test24533.hs:12:17-21 }))]))
+    (InstD
+     (NoExtField)
+     (ClsInstD
+      (NoExtField)
+      (ClsInstDecl
+       ((,,)
+        (Nothing)
+        [(AddEpAnn AnnInstance (EpaSpan { Test24533.hs:12:1-8 }))
+        ,(AddEpAnn AnnWhere (EpaSpan { Test24533.hs:12:17-21 }))]
+        (NoAnnSortKey))
+       (L
+        (EpAnn
+         (EpaSpan { Test24533.hs:12:10-15 })
+         (AnnListItem
+          [])
+         (EpaComments
+          []))
+        (HsSig
+         (NoExtField)
+         (HsOuterImplicit
+          (NoExtField))
+         (L
+          (EpAnn
+           (EpaSpan { Test24533.hs:12:10-15 })
+           (AnnListItem
+            [])
+           (EpaComments
+            []))
+          (HsAppTy
+           (NoExtField)
+           (L
+            (EpAnn
+             (EpaSpan { Test24533.hs:12:10-11 })
+             (AnnListItem
+              [])
+             (EpaComments
+              []))
+            (HsTyVar
+             []
+             (NotPromoted)
+             (L
+              (EpAnn
+               (EpaSpan { Test24533.hs:12:10-11 })
+               (NameAnnTrailing
+                [])
+               (EpaComments
+                []))
+              (Unqual
+               {OccName: Eq}))))
+           (L
+            (EpAnn
+             (EpaSpan { Test24533.hs:12:13-15 })
+             (AnnListItem
+              [])
+             (EpaComments
+              []))
+            (HsTyVar
+             []
+             (NotPromoted)
+             (L
+              (EpAnn
+               (EpaSpan { Test24533.hs:12:13-15 })
+               (NameAnnTrailing
+                [])
+               (EpaComments
+                []))
+              (Unqual
+               {OccName: Foo}))))))))
+       {Bag(LocatedA (HsBind GhcPs)):
+        [(L
+          (EpAnn
+           (EpaSpan { Test24533.hs:14:3-19 })
+           (AnnListItem
+            [])
+           (EpaComments
+            []))
+          (FunBind
+           (NoExtField)
+           (L
+            (EpAnn
+             (EpaSpan { Test24533.hs:14:7-8 })
+             (NameAnnTrailing
+              [])
+             (EpaComments
+              []))
+            (Unqual
+             {OccName: ==}))
+           (MG
+            (FromSource)
+            (L
+             (EpAnn
+              (EpaSpan { Test24533.hs:14:3-19 })
+              (AnnList
+               (Nothing)
+               (Nothing)
+               (Nothing)
+               []
+               [])
+              (EpaComments
+               []))
+             [(L
+               (EpAnn
+                (EpaSpan { Test24533.hs:14:3-19 })
+                (AnnListItem
+                 [])
+                (EpaComments
+                 []))
+               (Match
+                []
+                (FunRhs
+                 (L
+                  (EpAnn
+                   (EpaSpan { Test24533.hs:14:7-8 })
+                   (NameAnnTrailing
+                    [])
+                   (EpaComments
+                    []))
+                  (Unqual
+                   {OccName: ==}))
+                 (Infix)
+                 (NoSrcStrict))
+                [(L
+                  (EpAnn
+                   (EpaSpan { Test24533.hs:14:3-5 })
+                   (AnnListItem
+                    [])
+                   (EpaComments
+                    []))
+                  (VisPat
+                   (NoExtField)
+                   (L
+                    (EpAnn
+                     (EpaSpan { Test24533.hs:14:3-5 })
+                     (AnnListItem
+                      [])
+                     (EpaComments
+                      []))
+                    (ConPat
+                     []
+                     (L
+                      (EpAnn
+                       (EpaSpan { Test24533.hs:14:3-5 })
+                       (NameAnnTrailing
+                        [])
+                       (EpaComments
+                        []))
+                      (Unqual
+                       {OccName: Foo}))
+                     (PrefixCon
+                      []
+                      [])))))
+                ,(L
+                  (EpAnn
+                   (EpaSpan { Test24533.hs:14:10-12 })
+                   (AnnListItem
+                    [])
+                   (EpaComments
+                    []))
+                  (VisPat
+                   (NoExtField)
+                   (L
+                    (EpAnn
+                     (EpaSpan { Test24533.hs:14:10-12 })
+                     (AnnListItem
+                      [])
+                     (EpaComments
+                      []))
+                    (ConPat
+                     []
+                     (L
+                      (EpAnn
+                       (EpaSpan { Test24533.hs:14:10-12 })
+                       (NameAnnTrailing
+                        [])
+                       (EpaComments
+                        []))
+                      (Unqual
+                       {OccName: Foo}))
+                     (PrefixCon
+                      []
+                      [])))))]
+                (GRHSs
+                 (EpaComments
+                  [])
+                 [(L
+                   (EpAnn
+                    (EpaSpan { Test24533.hs:14:14-19 })
+                    (NoEpAnns)
+                    (EpaComments
+                     []))
+                   (GRHS
+                    (EpAnn
+                     (EpaSpan { Test24533.hs:14:14-19 })
+                     (GrhsAnn
+                      (Nothing)
+                      (AddEpAnn AnnEqual (EpaSpan { Test24533.hs:14:14 })))
+                     (EpaComments
+                      []))
+                    []
+                    (L
+                     (EpAnn
+                      (EpaSpan { Test24533.hs:14:16-19 })
+                      (AnnListItem
+                       [])
+                      (EpaComments
+                       []))
+                     (HsVar
+                      (NoExtField)
+                      (L
+                       (EpAnn
+                        (EpaSpan { Test24533.hs:14:16-19 })
+                        (NameAnnTrailing
+                         [])
+                        (EpaComments
+                         []))
+                       (Unqual
+                        {OccName: True}))))))]
+                 (EmptyLocalBinds
+                  (NoExtField)))))]))))]}
+       []
+       []
+       []
        (Nothing)))))]))
 
 
@@ -291,8 +608,8 @@
      []
      (Just
       ((,)
-       { Test24533.ppr.hs:3:41 }
-       { Test24533.ppr.hs:3:40 })))
+       { Test24533.ppr.hs:6:20 }
+       { Test24533.ppr.hs:6:16-19 })))
     (EpaCommentsBalanced
      [(L
        (EpaSpan
@@ -545,4 +862,311 @@
        []
        []
        []
-       (Nothing)))))]))
\ No newline at end of file
+       (Nothing)))))
+  ,(L
+    (EpAnn
+     (EpaSpan { Test24533.ppr.hs:4:1-21 })
+     (AnnListItem
+      [])
+     (EpaComments
+      []))
+    (TyClD
+     (NoExtField)
+     (ClassDecl
+      ((,,)
+       [(AddEpAnn AnnClass (EpaSpan { Test24533.ppr.hs:4:1-5 }))]
+       (EpNoLayout)
+       (NoAnnSortKey))
+      (Nothing)
+      (L
+       (EpAnn
+        (EpaSpan { Test24533.ppr.hs:4:7-9 })
+        (NameAnnTrailing
+         [])
+        (EpaComments
+         []))
+       (Unqual
+        {OccName: Foo}))
+      (HsQTvs
+       (NoExtField)
+       [(L
+         (EpAnn
+          (EpaSpan { Test24533.ppr.hs:4:11-21 })
+          (AnnListItem
+           [])
+          (EpaComments
+           []))
+         (KindedTyVar
+          [(AddEpAnn AnnOpenP (EpaSpan { Test24533.ppr.hs:4:11 }))
+          ,(AddEpAnn AnnCloseP (EpaSpan { Test24533.ppr.hs:4:21 }))
+          ,(AddEpAnn AnnDcolon (EpaSpan { Test24533.ppr.hs:4:14-15 }))]
+          (HsBndrRequired
+           (NoExtField))
+          (L
+           (EpAnn
+            (EpaSpan { Test24533.ppr.hs:4:12 })
+            (NameAnnTrailing
+             [])
+            (EpaComments
+             []))
+           (Unqual
+            {OccName: a}))
+          (L
+           (EpAnn
+            (EpaSpan { Test24533.ppr.hs:4:17-20 })
+            (AnnListItem
+             [])
+            (EpaComments
+             []))
+           (HsTyVar
+            []
+            (NotPromoted)
+            (L
+             (EpAnn
+              (EpaSpan { Test24533.ppr.hs:4:17-20 })
+              (NameAnnTrailing
+               [])
+              (EpaComments
+               []))
+             (Unqual
+              {OccName: Type}))))))])
+      (Prefix)
+      []
+      []
+      {Bag(LocatedA (HsBind GhcPs)):
+       []}
+      []
+      []
+      [])))
+  ,(L
+    (EpAnn
+     (EpaSpan { Test24533.ppr.hs:(5,1)-(6,19) })
+     (AnnListItem
+      [])
+     (EpaComments
+      []))
+    (InstD
+     (NoExtField)
+     (ClsInstD
+      (NoExtField)
+      (ClsInstDecl
+       ((,,)
+        (Nothing)
+        [(AddEpAnn AnnInstance (EpaSpan { Test24533.ppr.hs:5:1-8 }))
+        ,(AddEpAnn AnnWhere (EpaSpan { Test24533.ppr.hs:5:17-21 }))]
+        (NoAnnSortKey))
+       (L
+        (EpAnn
+         (EpaSpan { Test24533.ppr.hs:5:10-15 })
+         (AnnListItem
+          [])
+         (EpaComments
+          []))
+        (HsSig
+         (NoExtField)
+         (HsOuterImplicit
+          (NoExtField))
+         (L
+          (EpAnn
+           (EpaSpan { Test24533.ppr.hs:5:10-15 })
+           (AnnListItem
+            [])
+           (EpaComments
+            []))
+          (HsAppTy
+           (NoExtField)
+           (L
+            (EpAnn
+             (EpaSpan { Test24533.ppr.hs:5:10-11 })
+             (AnnListItem
+              [])
+             (EpaComments
+              []))
+            (HsTyVar
+             []
+             (NotPromoted)
+             (L
+              (EpAnn
+               (EpaSpan { Test24533.ppr.hs:5:10-11 })
+               (NameAnnTrailing
+                [])
+               (EpaComments
+                []))
+              (Unqual
+               {OccName: Eq}))))
+           (L
+            (EpAnn
+             (EpaSpan { Test24533.ppr.hs:5:13-15 })
+             (AnnListItem
+              [])
+             (EpaComments
+              []))
+            (HsTyVar
+             []
+             (NotPromoted)
+             (L
+              (EpAnn
+               (EpaSpan { Test24533.ppr.hs:5:13-15 })
+               (NameAnnTrailing
+                [])
+               (EpaComments
+                []))
+              (Unqual
+               {OccName: Foo}))))))))
+       {Bag(LocatedA (HsBind GhcPs)):
+        [(L
+          (EpAnn
+           (EpaSpan { Test24533.ppr.hs:6:3-19 })
+           (AnnListItem
+            [])
+           (EpaComments
+            []))
+          (FunBind
+           (NoExtField)
+           (L
+            (EpAnn
+             (EpaSpan { Test24533.ppr.hs:6:7-8 })
+             (NameAnnTrailing
+              [])
+             (EpaComments
+              []))
+            (Unqual
+             {OccName: ==}))
+           (MG
+            (FromSource)
+            (L
+             (EpAnn
+              (EpaSpan { Test24533.ppr.hs:6:3-19 })
+              (AnnList
+               (Nothing)
+               (Nothing)
+               (Nothing)
+               []
+               [])
+              (EpaComments
+               []))
+             [(L
+               (EpAnn
+                (EpaSpan { Test24533.ppr.hs:6:3-19 })
+                (AnnListItem
+                 [])
+                (EpaComments
+                 []))
+               (Match
+                []
+                (FunRhs
+                 (L
+                  (EpAnn
+                   (EpaSpan { Test24533.ppr.hs:6:7-8 })
+                   (NameAnnTrailing
+                    [])
+                   (EpaComments
+                    []))
+                  (Unqual
+                   {OccName: ==}))
+                 (Infix)
+                 (NoSrcStrict))
+                [(L
+                  (EpAnn
+                   (EpaSpan { Test24533.ppr.hs:6:3-5 })
+                   (AnnListItem
+                    [])
+                   (EpaComments
+                    []))
+                  (VisPat
+                   (NoExtField)
+                   (L
+                    (EpAnn
+                     (EpaSpan { Test24533.ppr.hs:6:3-5 })
+                     (AnnListItem
+                      [])
+                     (EpaComments
+                      []))
+                    (ConPat
+                     []
+                     (L
+                      (EpAnn
+                       (EpaSpan { Test24533.ppr.hs:6:3-5 })
+                       (NameAnnTrailing
+                        [])
+                       (EpaComments
+                        []))
+                      (Unqual
+                       {OccName: Foo}))
+                     (PrefixCon
+                      []
+                      [])))))
+                ,(L
+                  (EpAnn
+                   (EpaSpan { Test24533.ppr.hs:6:10-12 })
+                   (AnnListItem
+                    [])
+                   (EpaComments
+                    []))
+                  (VisPat
+                   (NoExtField)
+                   (L
+                    (EpAnn
+                     (EpaSpan { Test24533.ppr.hs:6:10-12 })
+                     (AnnListItem
+                      [])
+                     (EpaComments
+                      []))
+                    (ConPat
+                     []
+                     (L
+                      (EpAnn
+                       (EpaSpan { Test24533.ppr.hs:6:10-12 })
+                       (NameAnnTrailing
+                        [])
+                       (EpaComments
+                        []))
+                      (Unqual
+                       {OccName: Foo}))
+                     (PrefixCon
+                      []
+                      [])))))]
+                (GRHSs
+                 (EpaComments
+                  [])
+                 [(L
+                   (EpAnn
+                    (EpaSpan { Test24533.ppr.hs:6:14-19 })
+                    (NoEpAnns)
+                    (EpaComments
+                     []))
+                   (GRHS
+                    (EpAnn
+                     (EpaSpan { Test24533.ppr.hs:6:14-19 })
+                     (GrhsAnn
+                      (Nothing)
+                      (AddEpAnn AnnEqual (EpaSpan { Test24533.ppr.hs:6:14 })))
+                     (EpaComments
+                      []))
+                    []
+                    (L
+                     (EpAnn
+                      (EpaSpan { Test24533.ppr.hs:6:16-19 })
+                      (AnnListItem
+                       [])
+                      (EpaComments
+                       []))
+                     (HsVar
+                      (NoExtField)
+                      (L
+                       (EpAnn
+                        (EpaSpan { Test24533.ppr.hs:6:16-19 })
+                        (NameAnnTrailing
+                         [])
+                        (EpaComments
+                         []))
+                       (Unqual
+                        {OccName: True}))))))]
+                 (EmptyLocalBinds
+                  (NoExtField)))))]))))]}
+       []
+       []
+       []
+       (Nothing)))))]))
+
+


=====================================
testsuite/tests/rts/T22859.hs
=====================================
@@ -0,0 +1,71 @@
+{-# LANGUAGE NumericUnderscores #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE UnboxedTuples #-}
+
+import Control.Exception
+import Control.Exception.Backtrace
+import Control.Concurrent
+import Control.Concurrent.MVar
+import System.Mem
+import System.Mem.Experimental
+import GHC.IO (IO (..))
+import GHC.Exts
+import System.IO
+
+-- | Just do some work and hPutStrLn stderr to stdout to indicate that we are making progress
+worker :: IO ()
+worker = loop [] 2
+  where
+    loop !m !n
+      | n > 30 = hPutStrLn stderr . show $ length m
+      | otherwise = do
+          let x = show n
+          hPutStrLn stderr x
+          -- just to bulk out the allocations
+          IO (\s -> case newByteArray# 900000# s of (# s', arr# #) -> (# s', () #))
+          yield
+          loop (x:m) (n + 1)
+
+main :: IO ()
+main = do
+  done <- newMVar () -- we use this lock to wait for the worker to finish
+  started <- newEmptyMVar
+  let runWorker = do
+        forkIO . withMVar done $ \_ -> flip onException (hPutStrLn stderr "worker died") $ do
+          hPutStrLn stderr "worker starting"
+          putMVar started ()
+          setAllocationCounter 1_000_000
+          enableAllocationLimit
+          worker
+          hPutStrLn stderr "worker done"
+        takeMVar started
+        readMVar done
+        hFlush stderr
+        threadDelay 1000
+  -- default behaviour:
+  -- kill it after the limit is exceeded
+  hPutStrLn stderr "default behaviour"
+  runWorker
+  hPutStrLn stderr "just log once on the hook being triggered"
+  setGlobalAllocationLimitHandler DontKillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 1")
+  runWorker
+  hPutStrLn stderr "just log on the hook being triggered"
+  setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tid -> do
+    hPutStrLn stderr "allocation limit triggered 2"
+    -- re-enable the hook
+    setAllocationCounterFor 1_000_000 tid
+    enableAllocationLimitFor tid
+  runWorker
+  hPutStrLn stderr "kill from the hook"
+  setGlobalAllocationLimitHandler DontKillOnAllocationLimit . Just $ \tId -> throwTo tId AllocationLimitExceeded
+  runWorker
+  -- not super helpful, but let's test it anyway
+  hPutStrLn stderr "do nothing"
+  setGlobalAllocationLimitHandler DontKillOnAllocationLimit Nothing
+  runWorker
+  -- this is possible to handle using an exception handler instead.
+  hPutStrLn stderr "kill and log"
+  setGlobalAllocationLimitHandler KillOnAllocationLimit (Just $ \_ -> hPutStrLn stderr "allocation limit triggered 3")
+  runWorker
+  threadDelay 1000
+  hPutStrLn stderr "done"


=====================================
testsuite/tests/rts/T22859.stderr
=====================================
@@ -0,0 +1,152 @@
+default behaviour
+worker starting
+2
+3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+  collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+  toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+  throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+just log once on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 1
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+just log on the hook being triggered
+worker starting
+2
+3
+allocation limit triggered 2
+4
+5
+allocation limit triggered 2
+6
+7
+allocation limit triggered 2
+8
+9
+allocation limit triggered 2
+10
+11
+allocation limit triggered 2
+12
+13
+allocation limit triggered 2
+14
+15
+allocation limit triggered 2
+16
+17
+allocation limit triggered 2
+18
+19
+allocation limit triggered 2
+20
+21
+allocation limit triggered 2
+22
+23
+allocation limit triggered 2
+24
+25
+allocation limit triggered 2
+26
+27
+allocation limit triggered 2
+28
+29
+allocation limit triggered 2
+30
+29
+worker done
+kill from the hook
+worker starting
+2
+3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+  collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+  toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+  throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+do nothing
+worker starting
+2
+3
+4
+5
+6
+7
+8
+9
+10
+11
+12
+13
+14
+15
+16
+17
+18
+19
+20
+21
+22
+23
+24
+25
+26
+27
+28
+29
+30
+29
+worker done
+kill and log
+worker starting
+2
+3
+allocation limit triggered 3
+worker died
+T22859: allocation limit exceeded
+HasCallStack backtrace:
+  collectBacktraces, called at libraries/ghc-internal/src/GHC/Internal/Exception.hs:92:13 in ghc-internal:GHC.Internal.Exception
+  toExceptionWithBacktrace, called at libraries/ghc-internal/src/GHC/Internal/IO.hs:260:11 in ghc-internal:GHC.Internal.IO
+  throwIO, called at libraries/ghc-internal/src/GHC/Internal/Control/Exception/Base.hs:195:43 in ghc-internal:GHC.Internal.Control.Exception.Base
+
+
+done


=====================================
testsuite/tests/rts/all.T
=====================================
@@ -609,3 +609,5 @@ test('T23400', [], compile_and_run, ['-with-rtsopts -A8k'])
 test('IOManager', [js_skip, when(arch('wasm32'), skip), when(opsys('mingw32'), skip),
                    pre_cmd('$MAKE -s --no-print-directory IOManager.hs')],
                   compile_and_run, [''])
+
+test('T22859', [js_skip], compile_and_run, ['-with-rtsopts -A8K'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64ee01494af677371fbc33e13c2d830ea9d5eacd...b76643e056e7e09e48e040c1e1bb86020561b6a5

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/64ee01494af677371fbc33e13c2d830ea9d5eacd...b76643e056e7e09e48e040c1e1bb86020561b6a5
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/20240321/afcfa93c/attachment-0001.html>


More information about the ghc-commits mailing list