summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/codeGen/StgCmmForeign.hs4
-rw-r--r--compiler/prelude/primops.txt.pp14
-rw-r--r--includes/rts/Threads.h2
-rw-r--r--includes/stg/MiscClosures.h3
-rw-r--r--libraries/base/GHC/Conc/Sync.hs21
-rw-r--r--rts/PrimOps.cmm20
-rw-r--r--rts/RtsSymbols.c4
-rw-r--r--rts/Threads.c13
-rw-r--r--testsuite/tests/rts/all.T7
-rw-r--r--testsuite/tests/rts/alloccounter1.hs19
-rw-r--r--testsuite/tests/rts/alloccounter1.stdout1
11 files changed, 34 insertions, 74 deletions
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index 3473307423..fc3d42aa8b 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -408,8 +408,8 @@ Opening the nursery corresponds to the following code:
@
tso = CurrentTSO;
cn = CurrentNursery;
- bdfree = CurrentNursery->free;
- bdstart = CurrentNursery->start;
+ bdfree = CurrentNuresry->free;
+ bdstart = CurrentNuresry->start;
// We *add* the currently occupied portion of the nursery block to
// the allocation limit, because we will subtract it again in
diff --git a/compiler/prelude/primops.txt.pp b/compiler/prelude/primops.txt.pp
index 93482df03e..d8d7f6e3e1 100644
--- a/compiler/prelude/primops.txt.pp
+++ b/compiler/prelude/primops.txt.pp
@@ -2921,20 +2921,6 @@ primop TraceMarkerOp "traceMarker#" GenPrimOp
has_side_effects = True
out_of_line = True
-primop GetThreadAllocationCounter "getThreadAllocationCounter#" GenPrimOp
- State# RealWorld -> (# State# RealWorld, INT64 #)
- { Retrieves the allocation counter for the current thread. }
- with
- has_side_effects = True
- out_of_line = True
-
-primop SetThreadAllocationCounter "setThreadAllocationCounter#" GenPrimOp
- INT64 -> State# RealWorld -> State# RealWorld
- { Sets the allocation counter for the current thread to the given value. }
- with
- has_side_effects = True
- out_of_line = True
-
------------------------------------------------------------------------
section "Safe coercions"
------------------------------------------------------------------------
diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h
index f72f5ed121..fceacdc75d 100644
--- a/includes/rts/Threads.h
+++ b/includes/rts/Threads.h
@@ -43,6 +43,8 @@ StgRegTable * resumeThread (void *);
//
int cmp_thread (StgPtr tso1, StgPtr tso2);
int rts_getThreadId (StgPtr tso);
+HsInt64 rts_getThreadAllocationCounter (StgPtr tso);
+void rts_setThreadAllocationCounter (StgPtr tso, HsInt64 i);
void rts_enableThreadAllocationLimit (StgPtr tso);
void rts_disableThreadAllocationLimit (StgPtr tso);
diff --git a/includes/stg/MiscClosures.h b/includes/stg/MiscClosures.h
index 1fbfab9fbe..76cfbd6c8c 100644
--- a/includes/stg/MiscClosures.h
+++ b/includes/stg/MiscClosures.h
@@ -468,9 +468,6 @@ RTS_FUN_DECL(stg_traceCcszh);
RTS_FUN_DECL(stg_clearCCSzh);
RTS_FUN_DECL(stg_traceEventzh);
RTS_FUN_DECL(stg_traceMarkerzh);
-RTS_FUN_DECL(stg_getThreadAllocationCounterzh);
-RTS_FUN_DECL(stg_setThreadAllocationCounterzh);
-
/* Other misc stuff */
// See wiki:Commentary/Compiler/Backends/PprC#Prototypes
diff --git a/libraries/base/GHC/Conc/Sync.hs b/libraries/base/GHC/Conc/Sync.hs
index e15bcbcaa0..de7779291f 100644
--- a/libraries/base/GHC/Conc/Sync.hs
+++ b/libraries/base/GHC/Conc/Sync.hs
@@ -105,7 +105,6 @@ import Data.Maybe
import GHC.Base
import {-# SOURCE #-} GHC.IO.Handle ( hFlush )
import {-# SOURCE #-} GHC.IO.Handle.FD ( stdout )
-import GHC.Int
import GHC.IO
import GHC.IO.Encoding.UTF8
import GHC.IO.Exception
@@ -195,16 +194,18 @@ instance Ord ThreadId where
--
-- @since 4.8.0.0
setAllocationCounter :: Int64 -> IO ()
-setAllocationCounter (I64# i) = IO $ \s ->
- case setThreadAllocationCounter# i s of s' -> (# s', () #)
+setAllocationCounter i = do
+ ThreadId t <- myThreadId
+ rts_setThreadAllocationCounter t i
-- | Return the current value of the allocation counter for the
-- current thread.
--
-- @since 4.8.0.0
getAllocationCounter :: IO Int64
-getAllocationCounter = IO $ \s ->
- case getThreadAllocationCounter# s of (# s', ctr #) -> (# s', I64# ctr #)
+getAllocationCounter = do
+ ThreadId t <- myThreadId
+ rts_getThreadAllocationCounter t
-- | Enables the allocation counter to be treated as a limit for the
-- current thread. When the allocation limit is enabled, if the
@@ -241,6 +242,16 @@ disableAllocationLimit = do
ThreadId t <- myThreadId
rts_disableThreadAllocationLimit t
+-- We cannot do these operations safely on another thread, because on
+-- a 32-bit machine we cannot do atomic operations on a 64-bit value.
+-- Therefore, we only expose APIs that allow getting and setting the
+-- limit of the current thread.
+foreign import ccall unsafe "rts_setThreadAllocationCounter"
+ rts_setThreadAllocationCounter :: ThreadId# -> Int64 -> IO ()
+
+foreign import ccall unsafe "rts_getThreadAllocationCounter"
+ rts_getThreadAllocationCounter :: ThreadId# -> IO Int64
+
foreign import ccall unsafe "rts_enableThreadAllocationLimit"
rts_enableThreadAllocationLimit :: ThreadId# -> IO ()
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 1caa0c3343..2b3a304d06 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -2495,23 +2495,3 @@ stg_traceMarkerzh ( W_ msg )
return ();
}
-
-stg_getThreadAllocationCounterzh ()
-{
- // Account for the allocation in the current block
- W_ offset;
- offset = Hp - bdescr_start(CurrentNursery);
- return (StgTSO_alloc_limit(CurrentTSO) - offset);
-}
-
-stg_setThreadAllocationCounterzh ( I64 counter )
-{
- // Allocation in the current block will be subtracted by
- // getThreadAllocationCounter#, so we have to offset any existing
- // allocation here. See also openNursery/closeNursery in
- // compiler/codeGen/StgCmmForeign.hs.
- W_ offset;
- offset = Hp - bdescr_start(CurrentNursery);
- StgTSO_alloc_limit(CurrentTSO) = counter + offset;
- return ();
-}
diff --git a/rts/RtsSymbols.c b/rts/RtsSymbols.c
index 0fc98663ec..2ea6713eee 100644
--- a/rts/RtsSymbols.c
+++ b/rts/RtsSymbols.c
@@ -744,6 +744,8 @@
SymI_HasProto(rts_isProfiled) \
SymI_HasProto(rts_isDynamic) \
SymI_HasProto(rts_setInCallCapability) \
+ SymI_HasProto(rts_getThreadAllocationCounter) \
+ SymI_HasProto(rts_setThreadAllocationCounter) \
SymI_HasProto(rts_enableThreadAllocationLimit) \
SymI_HasProto(rts_disableThreadAllocationLimit) \
SymI_HasProto(rts_setMainThread) \
@@ -894,8 +896,6 @@
SymI_HasProto(stg_traceCcszh) \
SymI_HasProto(stg_traceEventzh) \
SymI_HasProto(stg_traceMarkerzh) \
- SymI_HasProto(stg_getThreadAllocationCounterzh) \
- SymI_HasProto(stg_setThreadAllocationCounterzh) \
SymI_HasProto(getMonotonicNSec) \
SymI_HasProto(lockFile) \
SymI_HasProto(unlockFile) \
diff --git a/rts/Threads.c b/rts/Threads.c
index c54156f383..b09dfa8ccc 100644
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -165,8 +165,19 @@ rts_getThreadId(StgPtr tso)
}
/* ---------------------------------------------------------------------------
- * Enabling and disabling the thread allocation limit
+ * Getting & setting the thread allocation limit
* ------------------------------------------------------------------------ */
+HsInt64 rts_getThreadAllocationCounter(StgPtr tso)
+{
+ // NB. doesn't take into account allocation in the current nursery
+ // block, so it might be off by up to 4k.
+ return PK_Int64((W_*)&(((StgTSO *)tso)->alloc_limit));
+}
+
+void rts_setThreadAllocationCounter(StgPtr tso, HsInt64 i)
+{
+ ASSIGN_Int64((W_*)&(((StgTSO *)tso)->alloc_limit), i);
+}
void rts_enableThreadAllocationLimit(StgPtr tso)
{
diff --git a/testsuite/tests/rts/all.T b/testsuite/tests/rts/all.T
index 7086d9113f..6377bde04f 100644
--- a/testsuite/tests/rts/all.T
+++ b/testsuite/tests/rts/all.T
@@ -382,10 +382,3 @@ test('T12903', [when(opsys('mingw32'), skip)], compile_and_run, [''])
test('T13832', exit_code(1), compile_and_run, ['-threaded'])
test('T13894', normal, compile_and_run, [''])
test('T14497', normal, compile_and_run, ['-O'])
-
-test('alloccounter1', normal, compile_and_run,
- [
- # avoid allocating stack chunks, which counts as
- # allocation and messes up the results:
- '-with-rtsopts=-k1m'
- ])
diff --git a/testsuite/tests/rts/alloccounter1.hs b/testsuite/tests/rts/alloccounter1.hs
deleted file mode 100644
index 4b81896d2c..0000000000
--- a/testsuite/tests/rts/alloccounter1.hs
+++ /dev/null
@@ -1,19 +0,0 @@
-module Main where
-
-import Control.Exception
-import Control.Monad
-import Data.List
-import System.Mem
-
-main = do
- let
- testAlloc n = do
- let start = 999999
- setAllocationCounter start
- evaluate (last [1..n])
- c <- getAllocationCounter
- -- print (start - c)
- return (start - c)
- results <- forM [1..1000] testAlloc
- print (sort results == results)
- -- results better be in ascending order
diff --git a/testsuite/tests/rts/alloccounter1.stdout b/testsuite/tests/rts/alloccounter1.stdout
deleted file mode 100644
index 0ca95142bb..0000000000
--- a/testsuite/tests/rts/alloccounter1.stdout
+++ /dev/null
@@ -1 +0,0 @@
-True
View Lorry Controller Status