diff options
| -rw-r--r-- | rts/Capability.c | 301 | ||||
| -rw-r--r-- | rts/Capability.h | 8 | ||||
| -rw-r--r-- | rts/RtsAPI.c | 2 | ||||
| -rw-r--r-- | rts/Schedule.c | 14 | ||||
| -rw-r--r-- | rts/Task.h | 11 | ||||
| -rw-r--r-- | testsuite/tests/concurrent/should_run/RandomPGC.hs | 597 | ||||
| -rw-r--r-- | testsuite/tests/concurrent/should_run/all.T | 4 | ||||
| -rw-r--r-- | testsuite/tests/concurrent/should_run/performGC.hs | 24 | ||||
| -rw-r--r-- | testsuite/tests/concurrent/should_run/performGC.stdout | 400 |
9 files changed, 1231 insertions, 130 deletions
diff --git a/rts/Capability.c b/rts/Capability.c index 21f63f39d9..b0b7f307b5 100644 --- a/rts/Capability.c +++ b/rts/Capability.c @@ -43,7 +43,7 @@ nat enabled_capabilities = 0; // The array of Capabilities. It's important that when we need // to allocate more Capabilities we don't have to move the existing // Capabilities, because there may be pointers to them in use -// (e.g. threads in waitForReturnCapability(), see #8209), so this is +// (e.g. threads in waitForCapability(), see #8209), so this is // an array of Capability* rather than an array of Capability. Capability **capabilities = NULL; @@ -450,11 +450,10 @@ giveCapabilityToTask (Capability *cap USED_IF_DEBUG, Task *task) #endif /* ---------------------------------------------------------------------------- - * Function: releaseCapability(Capability*) + * releaseCapability * - * Purpose: Letting go of a capability. Causes a - * 'returning worker' thread or a 'waiting worker' - * to wake up, in that order. + * The current Task (cap->task) releases the Capability. The Capability is + * marked free, and if there is any work to do, an appropriate Task is woken up. * ------------------------------------------------------------------------- */ #if defined(THREADED_RTS) @@ -474,13 +473,13 @@ releaseCapability_ (Capability* cap, // the go-ahead to return the result of an external call.. if (cap->returning_tasks_hd != NULL) { giveCapabilityToTask(cap,cap->returning_tasks_hd); - // The Task pops itself from the queue (see waitForReturnCapability()) + // The Task pops itself from the queue (see waitForCapability()) return; } // If there is a pending sync, then we should just leave the // Capability free. The thread trying to sync will be about to - // call waitForReturnCapability(). + // call waitForCapability(). if (pending_sync != 0 && pending_sync != SYNC_GC_PAR) { last_free_capability = cap; // needed? debugTrace(DEBUG_sched, "sync pending, set capability %d free", cap->no); @@ -549,62 +548,156 @@ releaseAndWakeupCapability (Capability* cap USED_IF_THREADS) } static void -releaseCapabilityAndQueueWorker (Capability* cap USED_IF_THREADS) +enqueueWorker (Capability* cap USED_IF_THREADS) { Task *task; - ACQUIRE_LOCK(&cap->lock); - task = cap->running_task; // If the Task is stopped, we shouldn't be yielding, we should // be just exiting. ASSERT(!task->stopped); + ASSERT(task->worker); - // If the current task is a worker, save it on the spare_workers - // list of this Capability. A worker can mark itself as stopped, - // in which case it is not replaced on the spare_worker queue. - // This happens when the system is shutting down (see - // Schedule.c:workerStart()). - if (!isBoundTask(task)) + if (cap->n_spare_workers < MAX_SPARE_WORKERS) + { + task->next = cap->spare_workers; + cap->spare_workers = task; + cap->n_spare_workers++; + } + else { - if (cap->n_spare_workers < MAX_SPARE_WORKERS) - { - task->next = cap->spare_workers; - cap->spare_workers = task; - cap->n_spare_workers++; + debugTrace(DEBUG_sched, "%d spare workers already, exiting", + cap->n_spare_workers); + releaseCapability_(cap,rtsFalse); + // hold the lock until after workerTaskStop; c.f. scheduleWorker() + workerTaskStop(task); + RELEASE_LOCK(&cap->lock); + shutdownThread(); + } +} + +#endif + +/* ---------------------------------------------------------------------------- + * waitForWorkerCapability(task) + * + * waits to be given a Capability, and then returns the Capability. The task + * must be either a worker (and on a cap->spare_workers queue), or a bound Task. + * ------------------------------------------------------------------------- */ + +#if defined(THREADED_RTS) + +static Capability * waitForWorkerCapability (Task *task) +{ + Capability *cap; + + for (;;) { + ACQUIRE_LOCK(&task->lock); + // task->lock held, cap->lock not held + if (!task->wakeup) waitCondition(&task->cond, &task->lock); + cap = task->cap; + task->wakeup = rtsFalse; + RELEASE_LOCK(&task->lock); + + debugTrace(DEBUG_sched, "woken up on capability %d", cap->no); + + ACQUIRE_LOCK(&cap->lock); + if (cap->running_task != NULL) { + debugTrace(DEBUG_sched, + "capability %d is owned by another task", cap->no); + RELEASE_LOCK(&cap->lock); + continue; } - else - { - debugTrace(DEBUG_sched, "%d spare workers already, exiting", - cap->n_spare_workers); - releaseCapability_(cap,rtsFalse); - // hold the lock until after workerTaskStop; c.f. scheduleWorker() - workerTaskStop(task); + + if (task->cap != cap) { + // see Note [migrated bound threads] + debugTrace(DEBUG_sched, + "task has been migrated to cap %d", task->cap->no); RELEASE_LOCK(&cap->lock); - shutdownThread(); + continue; + } + + if (task->incall->tso == NULL) { + ASSERT(cap->spare_workers != NULL); + // if we're not at the front of the queue, release it + // again. This is unlikely to happen. + if (cap->spare_workers != task) { + giveCapabilityToTask(cap,cap->spare_workers); + RELEASE_LOCK(&cap->lock); + continue; + } + cap->spare_workers = task->next; + task->next = NULL; + cap->n_spare_workers--; } + + cap->running_task = task; + RELEASE_LOCK(&cap->lock); + break; } - // Bound tasks just float around attached to their TSOs. - releaseCapability_(cap,rtsFalse); + return cap; +} - RELEASE_LOCK(&cap->lock); +#endif /* THREADED_RTS */ + +/* ---------------------------------------------------------------------------- + * waitForReturnCapability (Task *task) + * + * The Task should be on the cap->returning_tasks queue of a Capability. This + * function waits for the Task to be woken up, and returns the Capability that + * it was woken up on. + * + * ------------------------------------------------------------------------- */ + +#if defined(THREADED_RTS) + +static Capability * waitForReturnCapability (Task *task) +{ + Capability *cap; + + for (;;) { + ACQUIRE_LOCK(&task->lock); + // task->lock held, cap->lock not held + if (!task->wakeup) waitCondition(&task->cond, &task->lock); + cap = task->cap; + task->wakeup = rtsFalse; + RELEASE_LOCK(&task->lock); + + // now check whether we should wake up... + ACQUIRE_LOCK(&cap->lock); + if (cap->running_task == NULL) { + if (cap->returning_tasks_hd != task) { + giveCapabilityToTask(cap,cap->returning_tasks_hd); + RELEASE_LOCK(&cap->lock); + continue; + } + cap->running_task = task; + popReturningTask(cap); + RELEASE_LOCK(&cap->lock); + break; + } + RELEASE_LOCK(&cap->lock); + } + + return cap; } -#endif + +#endif /* THREADED_RTS */ /* ---------------------------------------------------------------------------- - * waitForReturnCapability (Capability **pCap, Task *task) + * waitForCapability (Capability **pCap, Task *task) * * Purpose: when an OS thread returns from an external call, - * it calls waitForReturnCapability() (via Schedule.resumeThread()) + * it calls waitForCapability() (via Schedule.resumeThread()) * to wait for permission to enter the RTS & communicate the * result of the external call back to the Haskell thread that * made it. * * ------------------------------------------------------------------------- */ -void -waitForReturnCapability (Capability **pCap, Task *task) + +void waitForCapability (Capability **pCap, Task *task) { #if !defined(THREADED_RTS) @@ -641,10 +734,9 @@ waitForReturnCapability (Capability **pCap, Task *task) ASSERT(task->cap == cap); } - ACQUIRE_LOCK(&cap->lock); - debugTrace(DEBUG_sched, "returning; I want capability %d", cap->no); + ACQUIRE_LOCK(&cap->lock); if (!cap->running_task) { // It's free; just grab it cap->running_task = task; @@ -652,31 +744,7 @@ waitForReturnCapability (Capability **pCap, Task *task) } else { newReturningTask(cap,task); RELEASE_LOCK(&cap->lock); - - for (;;) { - ACQUIRE_LOCK(&task->lock); - // task->lock held, cap->lock not held - if (!task->wakeup) waitCondition(&task->cond, &task->lock); - cap = task->cap; - task->wakeup = rtsFalse; - RELEASE_LOCK(&task->lock); - - // now check whether we should wake up... - ACQUIRE_LOCK(&cap->lock); - if (cap->running_task == NULL) { - if (cap->returning_tasks_hd != task) { - giveCapabilityToTask(cap,cap->returning_tasks_hd); - RELEASE_LOCK(&cap->lock); - continue; - } - cap->running_task = task; - popReturningTask(cap); - RELEASE_LOCK(&cap->lock); - break; - } - RELEASE_LOCK(&cap->lock); - } - + cap = waitForReturnCapability(task); } #ifdef PROFILING @@ -691,11 +759,30 @@ waitForReturnCapability (Capability **pCap, Task *task) #endif } -#if defined(THREADED_RTS) /* ---------------------------------------------------------------------------- * yieldCapability + * + * Give up the Capability, and return when we have it again. This is called + * when either we know that the Capability should be given to another Task, or + * there is nothing to do right now. One of the following is true: + * + * - The current Task is a worker, and there's a bound thread at the head of + * the run queue (or vice versa) + * + * - The run queue is empty. We'll be woken up again when there's work to + * do. + * + * - Another Task is trying to do parallel GC (pending_sync == SYNC_GC_PAR). + * We should become a GC worker for a while. + * + * - Another Task is trying to acquire all the Capabilities (pending_sync != + * SYNC_GC_PAR), either to do a sequential GC, forkProcess, or + * setNumCapabilities. We should give up the Capability temporarily. + * * ------------------------------------------------------------------------- */ +#if defined (THREADED_RTS) + /* See Note [GC livelock] in Schedule.c for why we have gcAllowed and return the rtsBool */ rtsBool /* Did we GC? */ @@ -714,63 +801,39 @@ yieldCapability (Capability** pCap, Task *task, rtsBool gcAllowed) } } - debugTrace(DEBUG_sched, "giving up capability %d", cap->no); + debugTrace(DEBUG_sched, "giving up capability %d", cap->no); - // We must now release the capability and wait to be woken up - // again. - task->wakeup = rtsFalse; - releaseCapabilityAndQueueWorker(cap); - - for (;;) { - ACQUIRE_LOCK(&task->lock); - // task->lock held, cap->lock not held - if (!task->wakeup) waitCondition(&task->cond, &task->lock); - cap = task->cap; - task->wakeup = rtsFalse; - RELEASE_LOCK(&task->lock); - - debugTrace(DEBUG_sched, "woken up on capability %d", cap->no); - - ACQUIRE_LOCK(&cap->lock); - if (cap->running_task != NULL) { - debugTrace(DEBUG_sched, - "capability %d is owned by another task", cap->no); - RELEASE_LOCK(&cap->lock); - continue; - } + // We must now release the capability and wait to be woken up again. + task->wakeup = rtsFalse; - if (task->cap != cap) { - // see Note [migrated bound threads] - debugTrace(DEBUG_sched, - "task has been migrated to cap %d", task->cap->no); - RELEASE_LOCK(&cap->lock); - continue; - } + ACQUIRE_LOCK(&cap->lock); - if (task->incall->tso == NULL) { - ASSERT(cap->spare_workers != NULL); - // if we're not at the front of the queue, release it - // again. This is unlikely to happen. - if (cap->spare_workers != task) { - giveCapabilityToTask(cap,cap->spare_workers); - RELEASE_LOCK(&cap->lock); - continue; - } - cap->spare_workers = task->next; - task->next = NULL; - cap->n_spare_workers--; - } + // If this is a worker thread, put it on the spare_workers queue + if (isWorker(task)) { + enqueueWorker(cap); + } - cap->running_task = task; - RELEASE_LOCK(&cap->lock); - break; - } + releaseCapability_(cap, rtsFalse); - debugTrace(DEBUG_sched, "resuming capability %d", cap->no); - ASSERT(cap->running_task == task); + if (isWorker(task) || isBoundTask(task)) { + RELEASE_LOCK(&cap->lock); + cap = waitForWorkerCapability(task); + } else { + // Not a worker Task, or a bound Task. The only way we can be woken up + // again is to put ourselves on the returning_tasks queue, so that's + // what we do. We still hold cap->lock at this point + // The Task waiting for this Capability does not have it + // yet, so we can be sure to be woken up later. (see #10545) + newReturningTask(cap,task); + RELEASE_LOCK(&cap->lock); + cap = waitForReturnCapability(task); + } + + debugTrace(DEBUG_sched, "resuming capability %d", cap->no); + ASSERT(cap->running_task == task); #ifdef PROFILING - cap->r.rCCCS = CCS_SYSTEM; + cap->r.rCCCS = CCS_SYSTEM; #endif *pCap = cap; @@ -780,6 +843,8 @@ yieldCapability (Capability** pCap, Task *task, rtsBool gcAllowed) return rtsFalse; } +#endif /* THREADED_RTS */ + // Note [migrated bound threads] // // There's a tricky case where: @@ -815,6 +880,8 @@ yieldCapability (Capability** pCap, Task *task, rtsBool gcAllowed) * get every Capability into the GC. * ------------------------------------------------------------------------- */ +#if defined (THREADED_RTS) + void prodCapability (Capability *cap, Task *task) { @@ -826,6 +893,8 @@ prodCapability (Capability *cap, Task *task) RELEASE_LOCK(&cap->lock); } +#endif /* THREADED_RTS */ + /* ---------------------------------------------------------------------------- * tryGrabCapability * @@ -833,6 +902,8 @@ prodCapability (Capability *cap, Task *task) * * ------------------------------------------------------------------------- */ +#if defined (THREADED_RTS) + rtsBool tryGrabCapability (Capability *cap, Task *task) { diff --git a/rts/Capability.h b/rts/Capability.h index 420bfd5c80..fb9f0aa181 100644 --- a/rts/Capability.h +++ b/rts/Capability.h @@ -248,7 +248,7 @@ extern volatile StgWord pending_sync; // // On return, *cap is non-NULL, and points to the Capability acquired. // -void waitForReturnCapability (Capability **cap/*in/out*/, Task *task); +void waitForCapability (Capability **cap/*in/out*/, Task *task); EXTERN_INLINE void recordMutableCap (StgClosure *p, Capability *cap, nat gen); @@ -269,12 +269,6 @@ EXTERN_INLINE void recordClosureMutated (Capability *cap, StgClosure *p); // rtsBool yieldCapability (Capability** pCap, Task *task, rtsBool gcAllowed); -// Acquires a capability for doing some work. -// -// On return: pCap points to the capability. -// -void waitForCapability (Task *task, Mutex *mutex, Capability **pCap); - // Wakes up a worker thread on just one Capability, used when we // need to service some global event. // diff --git a/rts/RtsAPI.c b/rts/RtsAPI.c index fb91fafdd3..2b3ad74a17 100644 --- a/rts/RtsAPI.c +++ b/rts/RtsAPI.c @@ -564,7 +564,7 @@ rts_lock (void) } cap = NULL; - waitForReturnCapability(&cap, task); + waitForCapability(&cap, task); if (task->incall->prev_stack == NULL) { // This is a new outermost call from C into Haskell land. diff --git a/rts/Schedule.c b/rts/Schedule.c index f81fc0e703..6edb7d063e 100644 --- a/rts/Schedule.c +++ b/rts/Schedule.c @@ -1424,7 +1424,7 @@ static void acquireAllCapabilities(Capability *cap, Task *task) // all the Capabilities, but even so it's a slightly // unsavoury invariant. task->cap = tmpcap; - waitForReturnCapability(&tmpcap, task); + waitForCapability(&tmpcap, task); if (tmpcap->no != i) { barf("acquireAllCapabilities: got the wrong capability"); } @@ -1801,7 +1801,7 @@ forkProcess(HsStablePtr *entry task = newBoundTask(); cap = NULL; - waitForReturnCapability(&cap, task); + waitForCapability(&cap, task); #ifdef THREADED_RTS do { @@ -2278,7 +2278,7 @@ resumeThread (void *task_) task->cap = cap; // Wait for permission to re-enter the RTS with the result. - waitForReturnCapability(&cap,task); + waitForCapability(&cap,task); // we might be on a different capability now... but if so, our // entry on the suspended_ccalls list will also have been // migrated. @@ -2408,7 +2408,7 @@ void scheduleWorker (Capability *cap, Task *task) // cap->lock until we've finished workerTaskStop() below. // // There may be workers still involved in foreign calls; those - // will just block in waitForReturnCapability() because the + // will just block in waitForCapability() because the // Capability has been shut down. // ACQUIRE_LOCK(&cap->lock); @@ -2499,7 +2499,7 @@ exitScheduler (rtsBool wait_foreign USED_IF_THREADS) if (sched_state < SCHED_SHUTTING_DOWN) { sched_state = SCHED_INTERRUPTING; Capability *cap = task->cap; - waitForReturnCapability(&cap,task); + waitForCapability(&cap,task); scheduleDoGC(&cap,task,rtsTrue); ASSERT(task->incall->tso == NULL); releaseCapability(cap); @@ -2523,7 +2523,7 @@ freeScheduler( void ) still_running = freeTaskManager(); // We can only free the Capabilities if there are no Tasks still // running. We might have a Task about to return from a foreign - // call into waitForReturnCapability(), for example (actually, + // call into waitForCapability(), for example (actually, // this should be the *only* thing that a still-running Task can // do at this point, and it will block waiting for the // Capability). @@ -2567,7 +2567,7 @@ performGC_(rtsBool force_major) // TODO: do we need to traceTask*() here? - waitForReturnCapability(&cap,task); + waitForCapability(&cap,task); scheduleDoGC(&cap,task,force_major); releaseCapability(cap); boundTaskExiting(task); diff --git a/rts/Task.h b/rts/Task.h index 5c7b049631..58798bd24d 100644 --- a/rts/Task.h +++ b/rts/Task.h @@ -167,6 +167,17 @@ isBoundTask (Task *task) return (task->incall->tso != NULL); } +// A Task is currently a worker if +// (a) it was created as a worker (task->worker), and +// (b) it has not left and re-entered Haskell, in which case +// task->incall->prev_stack would be non-NULL. +// +INLINE_HEADER rtsBool +isWorker (Task *task) +{ + return (task->worker && task->incall->prev_stack == NULL); +} + // Linked list of all tasks. // extern Task *all_tasks; diff --git a/testsuite/tests/concurrent/should_run/RandomPGC.hs b/testsuite/tests/concurrent/should_run/RandomPGC.hs new file mode 100644 index 0000000000..df4c58d48d --- /dev/null +++ b/testsuite/tests/concurrent/should_run/RandomPGC.hs @@ -0,0 +1,597 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 701 +{-# LANGUAGE Trustworthy #-} +#endif + +----------------------------------------------------------------------------- +-- | +-- Module : System.Random +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE in the 'random' repository) +-- +-- Maintainer : libraries@haskell.org +-- Stability : stable +-- Portability : portable +-- +-- This library deals with the common task of pseudo-random number +-- generation. The library makes it possible to generate repeatable +-- results, by starting with a specified initial random number generator, +-- or to get different results on each run by using the system-initialised +-- generator or by supplying a seed from some other source. +-- +-- The library is split into two layers: +-- +-- * A core /random number generator/ provides a supply of bits. +-- The class 'RandomGen' provides a common interface to such generators. +-- The library provides one instance of 'RandomGen', the abstract +-- data type 'StdGen'. Programmers may, of course, supply their own +-- instances of 'RandomGen'. +-- +-- * The class 'Random' provides a way to extract values of a particular +-- type from a random number generator. For example, the 'Float' +-- instance of 'Random' allows one to generate random values of type +-- 'Float'. +-- +-- This implementation uses the Portable Combined Generator of L'Ecuyer +-- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by +-- Lennart Augustsson. It has a period of roughly 2.30584e18. +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +module RandomPGC + ( + + -- $intro + + -- * Random number generators + +#ifdef ENABLE_SPLITTABLEGEN + RandomGen(next, genRange) + , SplittableGen(split) +#else + RandomGen(next, genRange, split) +#endif + -- ** Standard random number generators + , StdGen + , mkStdGen + + -- ** The global random number generator + + -- $globalrng + + , getStdRandom + , getStdGen + , setStdGen + , newStdGen + + -- * Random values of various types + , Random ( random, randomR, + randoms, randomRs, + randomIO, randomRIO ) + + -- * References + -- $references + + ) where + +import Prelude + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.C.Types + +#ifdef __NHC__ +import CPUTime ( getCPUTime ) +import Foreign.Ptr ( Ptr, nullPtr ) +import Foreign.C ( CTime, CUInt ) +#else +import System.CPUTime ( getCPUTime ) +import Data.Time ( getCurrentTime, UTCTime(..) ) +import Data.Ratio ( numerator, denominator ) +#endif +import Data.Char ( isSpace, chr, ord ) +import System.IO.Unsafe ( unsafePerformIO ) +import Data.IORef ( IORef, newIORef, readIORef, writeIORef ) +import Data.IORef ( atomicModifyIORef' ) +import Numeric ( readDec ) + +#ifdef __GLASGOW_HASKELL__ +import GHC.Exts ( build ) +#else +-- | A dummy variant of build without fusion. +{-# INLINE build #-} +build :: ((a -> [a] -> [a]) -> [a] -> [a]) -> [a] +build g = g (:) [] +#endif + +-- The standard nhc98 implementation of Time.ClockTime does not match +-- the extended one expected in this module, so we lash-up a quick +-- replacement here. +#ifdef __NHC__ +foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime +getTime :: IO (Integer, Integer) +getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) +#else +getTime :: IO (Integer, Integer) +getTime = do + utc <- getCurrentTime + let daytime = toRational $ utctDayTime utc + return $ quotRem (numerator daytime) (denominator daytime) +#endif + +-- | The class 'RandomGen' provides a common interface to random number +-- generators. +-- +#ifdef ENABLE_SPLITTABLEGEN +-- Minimal complete definition: 'next'. +#else +-- Minimal complete definition: 'next' and 'split'. +#endif + +class RandomGen g where + + -- |The 'next' operation returns an 'Int' that is uniformly distributed + -- in the range returned by 'genRange' (including both end points), + -- and a new generator. + next :: g -> (Int, g) + + -- |The 'genRange' operation yields the range of values returned by + -- the generator. + -- + -- It is required that: + -- + -- * If @(a,b) = 'genRange' g@, then @a < b@. + -- + -- * 'genRange' always returns a pair of defined 'Int's. + -- + -- The second condition ensures that 'genRange' cannot examine its + -- argument, and hence the value it returns can be determined only by the + -- instance of 'RandomGen'. That in turn allows an implementation to make + -- a single call to 'genRange' to establish a generator's range, without + -- being concerned that the generator returned by (say) 'next' might have + -- a different range to the generator passed to 'next'. + -- + -- The default definition spans the full range of 'Int'. + genRange :: g -> (Int,Int) + + -- default method + genRange _ = (minBound, maxBound) + +#ifdef ENABLE_SPLITTABLEGEN +-- | The class 'SplittableGen' proivides a way to specify a random number +-- generator that can be split into two new generators. +class SplittableGen g where +#endif + -- |The 'split' operation allows one to obtain two distinct random number + -- generators. This is very useful in functional programs (for example, when + -- passing a random number generator down to recursive calls), but very + -- little work has been done on statistically robust implementations of + -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] + -- are the only examples we know of). + split :: g -> (g, g) + +{- | +The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. + +The result of repeatedly using 'next' should be at least as statistically +robust as the /Minimal Standard Random Number Generator/ described by +["System.Random\#Park", "System.Random\#Carta"]. +Until more is known about implementations of 'split', all we require is +that 'split' deliver generators that are (a) not identical and +(b) independently robust in the sense just given. + +The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the +state of a random number generator. +It is required that @'read' ('show' g) == g@. + +In addition, 'reads' may be used to map an arbitrary string (not necessarily one +produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' +instance of 'StdGen' has the following properties: + +* It guarantees to succeed on any string. + +* It guarantees to consume only a finite portion of the string. + +* Different argument strings are likely to result in different results. + +-} + +data StdGen + = StdGen !Int32 !Int32 + +instance RandomGen StdGen where + next = stdNext + genRange _ = stdRange + +#ifdef ENABLE_SPLITTABLEGEN +instance SplittableGen StdGen where +#endif + split = stdSplit + +instance Show StdGen where + showsPrec p (StdGen s1 s2) = + showsPrec p s1 . + showChar ' ' . + showsPrec p s2 + +instance Read StdGen where + readsPrec _p = \ r -> + case try_read r of + r'@[_] -> r' + _ -> [stdFromString r] -- because it shouldn't ever fail. + where + try_read r = do + (s1, r1) <- readDec (dropWhile isSpace r) + (s2, r2) <- readDec (dropWhile isSpace r1) + return (StdGen s1 s2, r2) + +{- + If we cannot unravel the StdGen from a string, create + one based on the string given. +-} +stdFromString :: String -> (StdGen, String) +stdFromString s = (mkStdGen num, rest) + where (cs, rest) = splitAt 6 s + num = foldl (\a x -> x + 3 * a) 1 (map ord cs) + + +{- | +The function 'mkStdGen' provides an alternative way of producing an initial +generator, by mapping an 'Int' into a generator. Again, distinct arguments +should be likely to produce distinct generators. +-} +mkStdGen :: Int -> StdGen -- why not Integer ? +mkStdGen s = mkStdGen32 $ fromIntegral s + +{- +From ["System.Random\#LEcuyer"]: "The integer variables s1 and s2 ... must be +initialized to values in the range [1, 2147483562] and [1, 2147483398] +respectively." +-} +mkStdGen32 :: Int32 -> StdGen +mkStdGen32 sMaybeNegative = StdGen (s1+1) (s2+1) + where + -- We want a non-negative number, but we can't just take the abs + -- of sMaybeNegative as -minBound == minBound. + s = sMaybeNegative .&. maxBound + (q, s1) = s `divMod` 2147483562 + s2 = q `mod` 2147483398 + +createStdGen :: Integer -> StdGen +createStdGen s = mkStdGen32 $ fromIntegral s + +{- | +With a source of random number supply in hand, the 'Random' class allows the +programmer to extract random values of a variety of types. + +Minimal complete definition: 'randomR' and 'random'. + +-} + +class Random a where + -- | Takes a range /(lo,hi)/ and a random number generator + -- /g/, and returns a random value uniformly distributed in the closed + -- interval /[lo,hi]/, together with a new generator. It is unspecified + -- what happens if /lo>hi/. For continuous types there is no requirement + -- that the values /lo/ and /hi/ are ever produced, but they may be, + -- depending on the implementation and the interval. + randomR :: RandomGen g => (a,a) -> g -> (a,g) + + -- | The same as 'randomR', but using a default range determined by the type: + -- + -- * For bounded types (instances of 'Bounded', such as 'Char'), + -- the range is normally the whole type. + -- + -- * For fractional types, the range is normally the semi-closed interval + -- @[0,1)@. + -- + -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. + random :: RandomGen g => g -> (a, g) + + -- | Plural variant of 'randomR', producing an infinite list of + -- random values instead of returning a new generator. + {-# INLINE randomRs #-} + randomRs :: RandomGen g => (a,a) -> g -> [a] + randomRs ival g = build (\cons _nil -> buildRandoms cons (randomR ival) g) + + -- | Plural variant of 'random', producing an infinite list of + -- random values instead of returning a new generator. + {-# INLINE randoms #-} + randoms :: RandomGen g => g -> [a] + randoms g = build (\cons _nil -> buildRandoms cons random g) + + -- | A variant of 'randomR' that uses the global random number generator + -- (see "System.Random#globalrng"). + randomRIO :: (a,a) -> IO a + randomRIO range = getStdRandom (randomR range) + + -- | A variant of 'random' that uses the global random number generator + -- (see "System.Random#globalrng"). + randomIO :: IO a + randomIO = getStdRandom random + +-- | Produce an infinite list-equivalent of random values. +{-# INLINE buildRandoms #-} +buildRandoms :: RandomGen g + => (a -> as -> as) -- ^ E.g. '(:)' but subject to fusion + -> (g -> (a,g)) -- ^ E.g. 'random' + -> g -- ^ A 'RandomGen' instance + -> as +buildRandoms cons rand = go + where + -- The seq fixes part of #4218 and also makes fused Core simpler. + go g = x `seq` (x `cons` go g') where (x,g') = rand g + + +instance Random Integer where + randomR ival g = randomIvalInteger ival g + random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g + +instance Random Int where randomR = randomIvalIntegral; random = randomBounded +instance Random Int8 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int16 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int32 where randomR = randomIvalIntegral; random = randomBounded +instance Random Int64 where randomR = randomIvalIntegral; random = randomBounded + +#ifndef __NHC__ +-- Word is a type synonym in nhc98. +instance Random Word where randomR = randomIvalIntegral; random = randomBounded +#endif +instance Random Word8 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word16 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word32 where randomR = randomIvalIntegral; random = randomBounded +instance Random Word64 where randomR = randomIvalIntegral; random = randomBounded + +instance Random CChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CSChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CUChar where randomR = randomIvalIntegral; random = randomBounded +instance Random CShort where randomR = randomIvalIntegral; random = randomBounded +instance Random CUShort where randomR = randomIvalIntegral; random = randomBounded +instance Random CInt where randomR = randomIvalIntegral; random = randomBounded +instance Random CUInt where randomR = randomIvalIntegral; random = randomBounded +instance Random CLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CULong where randomR = randomIvalIntegral; random = randomBounded +instance Random CPtrdiff where randomR = randomIvalIntegral; random = randomBounded +instance Random CSize where randomR = randomIvalIntegral; random = randomBounded +instance Random CWchar where randomR = randomIvalIntegral; random = randomBounded +instance Random CSigAtomic where randomR = randomIvalIntegral; random = randomBounded +instance Random CLLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CULLong where randomR = randomIvalIntegral; random = randomBounded +instance Random CIntPtr where randomR = randomIvalIntegral; random = randomBounded +instance Random CUIntPtr where randomR = randomIvalIntegral; random = randomBounded +instance Random CIntMax where randomR = randomIvalIntegral; random = randomBounded +instance Random CUIntMax where randomR = randomIvalIntegral; random = randomBounded + +instance Random Char where + randomR (a,b) g = + case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of + (x,g') -> (chr x, g') + random g = randomR (minBound,maxBound) g + +instance Random Bool where + randomR (a,b) g = + case (randomIvalInteger (bool2Int a, bool2Int b) g) of + (x, g') -> (int2Bool x, g') + where + bool2Int :: Bool -> Integer + bool2Int False = 0 + bool2Int True = 1 + + int2Bool :: Int -> Bool + int2Bool 0 = False + int2Bool _ = True + + random g = randomR (minBound,maxBound) g + +{-# INLINE randomRFloating #-} +randomRFloating :: (Fractional a, Num a, Ord a, Random a, RandomGen g) => (a, a) -> g -> (a, g) +randomRFloating (l,h) g + | l>h = randomRFloating (h,l) g + | otherwise = let (coef,g') = random g in + (2.0 * (0.5*l + coef * (0.5*h - 0.5*l)), g') -- avoid overflow + +instance Random Double where + randomR = randomRFloating + random rng = + case random rng of + (x,rng') -> + -- We use 53 bits of randomness corresponding to the 53 bit significand: + ((fromIntegral (mask53 .&. (x::Int64)) :: Double) + / fromIntegral twoto53, rng') + where + twoto53 = (2::Int64) ^ (53::Int64) + mask53 = twoto53 - 1 + +instance Random Float where + randomR = randomRFloating + random rng = + -- TODO: Faster to just use 'next' IF it generates enough bits of randomness. + case random rng of + (x,rng') -> + -- We use 24 bits of randomness corresponding to the 24 bit significand: + ((fromIntegral (mask24 .&. (x::Int32)) :: Float) + / fromIntegral twoto24, rng') + -- Note, encodeFloat is another option, but I'm not seeing slightly + -- worse performance with the following [2011.06.25]: +-- (encodeFloat rand (-24), rng') + where + mask24 = twoto24 - 1 + twoto24 = (2::Int32) ^ (24::Int32) + +-- CFloat/CDouble are basically the same as a Float/Double: +instance Random CFloat where + randomR = randomRFloating + random rng = case random rng of + (x,rng') -> (realToFrac (x::Float), rng') + +instance Random CDouble where + randomR = randomRFloating + -- A MYSTERY: + -- Presently, this is showing better performance than the Double instance: + -- (And yet, if the Double instance uses randomFrac then its performance is much worse!) + random = randomFrac + -- random rng = case random rng of + -- (x,rng') -> (realToFrac (x::Double), rng') + +mkStdRNG :: Integer -> IO StdGen +mkStdRNG o = do + ct <- getCPUTime + (sec, psec) <- getTime + return (createStdGen (sec * 12345 + psec + ct + o)) + +randomBounded :: (RandomGen g, Random a, Bounded a) => g -> (a, g) +randomBounded = randomR (minBound, maxBound) + +-- The two integer functions below take an [inclusive,inclusive] range. +randomIvalIntegral :: (RandomGen g, Integral a) => (a, a) -> g -> (a, g) +randomIvalIntegral (l,h) = randomIvalInteger (toInteger l, toInteger h) + +{-# SPECIALIZE randomIvalInteger :: (Num a) => + (Integer, Integer) -> StdGen -> (a, StdGen) #-} + +randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) +randomIvalInteger (l,h) rng + | l > h = randomIvalInteger (h,l) rng + | otherwise = case (f 1 0 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') + where + (genlo, genhi) = genRange rng + b = fromIntegral genhi - fromIntegral genlo + 1 + + -- Probabilities of the most likely and least likely result + -- will differ at most by a factor of (1 +- 1/q). Assuming the RandomGen + -- is uniform, of course + + -- On average, log q / log b more random values will be generated + -- than the minimum + q = 1000 + k = h - l + 1 + magtgt = k * q + + -- generate random values until we exceed the target magnitude + f mag v g | mag >= magtgt = (v, g) + | otherwise = v' `seq`f (mag*b) v' g' where + (x,g') = next g + v' = (v * b + (fromIntegral x - fromIntegral genlo)) + + +-- The continuous functions on the other hand take an [inclusive,exclusive) range. +randomFrac :: (RandomGen g, Fractional a) => g -> (a, g) +randomFrac = randomIvalDouble (0::Double,1) realToFrac + +randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) +randomIvalDouble (l,h) fromDouble rng + | l > h = randomIvalDouble (h,l) fromDouble rng + | otherwise = + case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of + (x, rng') -> + let + scaled_x = + fromDouble (0.5*l + 0.5*h) + -- previously (l+h)/2, overflowed + fromDouble ((0.5*h - 0.5*l) / (0.5 * realToFrac int32Count)) * -- avoid overflow + fromIntegral (x::Int32) + in + (scaled_x, rng') + +int32Count :: Integer +int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 -- GHC ticket #3982 + +stdRange :: (Int,Int) +stdRange = (1, 2147483562) + +stdNext :: StdGen -> (Int, StdGen) +-- Returns values in the range stdRange +stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') + where z' = if z < 1 then z + 2147483562 else z + z = s1'' - s2'' + + k = s1 `quot` 53668 + s1' = 40014 * (s1 - k * 53668) - k * 12211 + s1'' = if s1' < 0 then s1' + 2147483563 else s1' + + k' = s2 `quot` 52774 + s2' = 40692 * (s2 - k' * 52774) - k' * 3791 + s2'' = if s2' < 0 then s2' + 2147483399 else s2' + +stdSplit :: StdGen -> (StdGen, StdGen) +stdSplit std@(StdGen s1 s2) + = (left, right) + where + -- no statistical foundation for this! + left = StdGen new_s1 t2 + right = StdGen t1 new_s2 + + new_s1 | s1 == 2147483562 = 1 + | otherwise = s1 + 1 + + new_s2 | s2 == 1 = 2147483398 + | otherwise = s2 - 1 + + StdGen t1 t2 = snd (next std) + +-- The global random number generator + +{- $globalrng #globalrng# + +There is a single, implicit, global random number generator of type +'StdGen', held in some global variable maintained by the 'IO' monad. It is +initialised automatically in some system-dependent fashion, for example, by +using the time of day, or Linux's kernel random number generator. To get +deterministic behaviour, use 'setStdGen'. +-} + +-- |Sets the global random number generator. +setStdGen :: StdGen -> IO () +setStdGen sgen = writeIORef theStdGen sgen + +-- |Gets the global random number generator. +getStdGen :: IO StdGen +getStdGen = readIORef theStdGen + +theStdGen :: IORef StdGen +theStdGen = unsafePerformIO $ do + rng <- mkStdRNG 0 + newIORef rng + +-- |Applies 'split' to the current global random generator, +-- updates it with one of the results, and returns the other. +newStdGen :: IO StdGen +newStdGen = atomicModifyIORef' theStdGen split + +{- |Uses the supplied function to get a value from the current global +random generator, and updates the global generator with the new generator +returned by the function. For example, @rollDice@ gets a random integer +between 1 and 6: + +> rollDice :: IO Int +> rollDice = getStdRandom (randomR (1,6)) + +-} + +getStdRandom :: (StdGen -> (a,StdGen)) -> IO a +getStdRandom f = atomicModifyIORef' theStdGen (swap . f) + where swap (v,g) = (g,v) + +{- $references + +1. FW #Burton# Burton and RL Page, /Distributed random number generation/, +Journal of Functional Programming, 2(2):203-212, April 1992. + +2. SK #Park# Park, and KW Miller, /Random number generators - +good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. + +3. DG #Carta# Carta, /Two fast implementations of the minimal standard +random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. + +4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, +Department of Mathematics, University of Salzburg, +<http://random.mat.sbg.ac.at/~peter/pads98.ps>, 1998. + +5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random +number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. + +The Web site <http://random.mat.sbg.ac.at/> is a great source of information. + +-} diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T index 3d059bdcf7..17d32ea0a4 100644 --- a/testsuite/tests/concurrent/should_run/all.T +++ b/testsuite/tests/concurrent/should_run/all.T @@ -104,6 +104,10 @@ test('allocLimit4', [ extra_run_opts('+RTS -xq300k -RTS'), omit_ways(['ghci']) ], compile_and_run, ['']) +test('performGC', [ only_ways(['threaded1','threaded2']) + , extra_run_opts('400 +RTS -qg -RTS') ], + compile_and_run, ['']) + # ----------------------------------------------------------------------------- # These tests we only do for a full run diff --git a/testsuite/tests/concurrent/should_run/performGC.hs b/testsuite/tests/concurrent/should_run/performGC.hs new file mode 100644 index 0000000000..87a32711ca --- /dev/null +++ b/testsuite/tests/concurrent/should_run/performGC.hs @@ -0,0 +1,24 @@ +module Main (main) where + +-- Test for #10545 + +import System.Environment +import Control.Concurrent +import Control.Exception +import Control.Monad +import RandomPGC +import System.Mem +import qualified Data.Set as Set + +main = do + [n] <- getArgs + forkIO $ doSomeWork + forM [1..read n] $ \n -> do print n; threadDelay 1000; performMinorGC + +doSomeWork :: IO () +doSomeWork = forever $ do + ns <- replicateM 10000 randomIO :: IO [Int] + ms <- replicateM 1000 randomIO + let set = Set.fromList ns + elems = filter (`Set.member` set) ms + evaluate $ sum elems diff --git a/testsuite/tests/concurrent/should_run/performGC.stdout b/testsuite/tests/concurrent/should_run/performGC.stdout new file mode 100644 index 0000000000..7b5d34d5cf --- /dev/null +++ b/testsuite/tests/concurrent/should_run/performGC.stdout @@ -0,0 +1,400 @@ +1 +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 +31 +32 +33 +34 +35 +36 +37 +38 +39 +40 +41 +42 +43 +44 +45 +46 +47 +48 +49 +50 +51 +52 +53 +54 +55 +56 +57 +58 +59 +60 +61 +62 +63 +64 +65 +66 +67 +68 +69 +70 +71 +72 +73 +74 +75 +76 +77 +78 +79 +80 +81 +82 +83 +84 +85 +86 +87 +88 +89 +90 +91 +92 +93 +94 +95 +96 +97 +98 +99 +100 +101 +102 +103 +104 +105 +106 +107 +108 +109 +110 +111 +112 +113 +114 +115 +116 +117 +118 +119 +120 +121 +122 +123 +124 +125 +126 +127 +128 +129 +130 +131 +132 +133 +134 +135 +136 +137 +138 +139 +140 +141 +142 +143 +144 +145 +146 +147 +148 +149 +150 +151 +152 +153 +154 +155 +156 +157 +158 +159 +160 +161 +162 +163 +164 +165 +166 +167 +168 +169 +170 +171 +172 +173 +174 +175 +176 +177 +178 +179 +180 +181 +182 +183 +184 +185 +186 +187 +188 +189 +190 +191 +192 +193 +194 +195 +196 +197 +198 +199 +200 +201 +202 +203 +204 +205 +206 +207 +208 +209 +210 +211 +212 +213 +214 +215 +216 +217 +218 +219 +220 +221 +222 +223 +224 +225 +226 +227 +228 +229 +230 +231 +232 +233 +234 +235 +236 +237 +238 +239 +240 +241 +242 +243 +244 +245 +246 +247 +248 +249 +250 +251 +252 +253 +254 +255 +256 +257 +258 +259 +260 +261 +262 +263 +264 +265 +266 +267 +268 +269 +270 +271 +272 +273 +274 +275 +276 +277 +278 +279 +280 +281 +282 +283 +284 +285 +286 +287 +288 +289 +290 +291 +292 +293 +294 +295 +296 +297 +298 +299 +300 +301 +302 +303 +304 +305 +306 +307 +308 +309 +310 +311 +312 +313 +314 +315 +316 +317 +318 +319 +320 +321 +322 +323 +324 +325 +326 +327 +328 +329 +330 +331 +332 +333 +334 +335 +336 +337 +338 +339 +340 +341 +342 +343 +344 +345 +346 +347 +348 +349 +350 +351 +352 +353 +354 +355 +356 +357 +358 +359 +360 +361 +362 +363 +364 +365 +366 +367 +368 +369 +370 +371 +372 +373 +374 +375 +376 +377 +378 +379 +380 +381 +382 +383 +384 +385 +386 +387 +388 +389 +390 +391 +392 +393 +394 +395 +396 +397 +398 +399 +400 |