Revert "Improve accuracy of get/setAllocationCounter"
authorBen Gamari <ben@smart-cactus.org>
Thu, 18 Jan 2018 05:50:31 +0000 (00:50 -0500)
committerBen Gamari <ben@smart-cactus.org>
Thu, 18 Jan 2018 05:50:31 +0000 (00:50 -0500)
This reverts commit a1a689dda48113f3735834350fb562bb1927a633.

compiler/codeGen/StgCmmForeign.hs
compiler/prelude/primops.txt.pp
includes/rts/Threads.h
includes/stg/MiscClosures.h
libraries/base/GHC/Conc/Sync.hs
rts/PrimOps.cmm
rts/RtsSymbols.c
rts/Threads.c
testsuite/tests/rts/all.T
testsuite/tests/rts/alloccounter1.hs [deleted file]
testsuite/tests/rts/alloccounter1.stdout [deleted file]

index 3473307..fc3d42a 100644 (file)
@@ -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
index 93482df..d8d7f6e 100644 (file)
@@ -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"
 ------------------------------------------------------------------------
index f72f5ed..fceacdc 100644 (file)
@@ -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);
 
index 1fbfab9..76cfbd6 100644 (file)
@@ -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
index e15bcbc..de77792 100644 (file)
@@ -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 ()
 
index 1caa0c3..2b3a304 100644 (file)
@@ -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 ();
-}
index 0fc9866..2ea6713 100644 (file)
       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)                                  \
       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)                                         \
index c54156f..b09dfa8 100644 (file)
@@ -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)
 {
index 7086d91..6377bde 100644 (file)
@@ -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 (file)
index 4b81896..0000000
+++ /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 (file)
index 0ca9514..0000000
+++ /dev/null
@@ -1 +0,0 @@
-True