From a599281d81d9c5944e3631425bea7bc0e9052c74 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 14 Feb 2001 12:59:35 +0000 Subject: [PATCH] [project @ 2001-02-14 12:59:34 by simonmar] - make putMVar block rather than raise an exception when it encounters a full MVar (to match the semantics in our recent paper on async excpetions). - add tryPutMVar, a non-blocking version of putMVar. --- ghc/compiler/prelude/primops.txt | 24 ++++--- ghc/includes/PrimOps.h | 6 +- ghc/lib/std/PrelGHC.hi-boot | 1 + ghc/rts/Prelude.h | 3 +- ghc/rts/PrimOps.hc | 108 ++++++++++++++++++++++++++-- ghc/tests/concurrent/should_run/conc026.hs | 8 +++ ghc/tests/concurrent/should_run/conc027.hs | 9 +++ 7 files changed, 139 insertions(+), 20 deletions(-) create mode 100644 ghc/tests/concurrent/should_run/conc026.hs create mode 100644 ghc/tests/concurrent/should_run/conc027.hs diff --git a/ghc/compiler/prelude/primops.txt b/ghc/compiler/prelude/primops.txt index 73d145e..1d3d99a 100644 --- a/ghc/compiler/prelude/primops.txt +++ b/ghc/compiler/prelude/primops.txt @@ -1,5 +1,5 @@ ----------------------------------------------------------------------- --- $Id: primops.txt,v 1.15 2001/01/15 16:55:24 sewardj Exp $ +-- $Id: primops.txt,v 1.16 2001/02/14 12:59:35 simonmar Exp $ -- -- Primitive Operations -- @@ -1001,6 +1001,13 @@ primop TakeMVarOp "takeMVar#" GenPrimOp has_side_effects = True out_of_line = True +primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp + MVar# s a -> State# s -> (# State# s, Int#, a #) + with + usage = { mangle TryTakeMVarOp [mkM, mkP] mkM } + has_side_effects = True + out_of_line = True + primop PutMVarOp "putMVar#" GenPrimOp MVar# s a -> a -> State# s -> State# s with @@ -1009,18 +1016,19 @@ primop PutMVarOp "putMVar#" GenPrimOp has_side_effects = True out_of_line = True +primop TryPutMVarOp "tryPutMVar#" GenPrimOp + MVar# s a -> a -> State# s -> (# State# s, Int# #) + with + strictness = { \ arity -> StrictnessInfo [wwPrim, wwLazy, wwPrim] False } + usage = { mangle PutMVarOp [mkM, mkM, mkP] mkR } + has_side_effects = True + out_of_line = True + primop SameMVarOp "sameMVar#" GenPrimOp MVar# s a -> MVar# s a -> Bool with usage = { mangle SameMVarOp [mkP, mkP] mkM } -primop TryTakeMVarOp "tryTakeMVar#" GenPrimOp - MVar# s a -> State# s -> (# State# s, Int#, a #) - with - usage = { mangle TryTakeMVarOp [mkM, mkP] mkM } - has_side_effects = True - out_of_line = True - primop IsEmptyMVarOp "isEmptyMVar#" GenPrimOp MVar# s a -> State# s -> (# State# s, Int# #) with diff --git a/ghc/includes/PrimOps.h b/ghc/includes/PrimOps.h index cb1aa8c..7136b7c 100644 --- a/ghc/includes/PrimOps.h +++ b/ghc/includes/PrimOps.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.h,v 1.73 2001/01/24 15:37:34 simonmar Exp $ + * $Id: PrimOps.h,v 1.74 2001/02/14 12:59:34 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -698,9 +698,9 @@ EXTFUN_RTS(newMutVarzh_fast); #define isEmptyMVarzh(r,a) r=(I_)((GET_INFO((StgMVar*)(a))) == &stg_EMPTY_MVAR_info ) EXTFUN_RTS(newMVarzh_fast); EXTFUN_RTS(takeMVarzh_fast); -EXTFUN_RTS(tryTakeMVarzh_fast); EXTFUN_RTS(putMVarzh_fast); - +EXTFUN_RTS(tryTakeMVarzh_fast); +EXTFUN_RTS(tryPutMVarzh_fast); /* ----------------------------------------------------------------------------- Delay/Wait PrimOps diff --git a/ghc/lib/std/PrelGHC.hi-boot b/ghc/lib/std/PrelGHC.hi-boot index b23a0a0..ff89ad1 100644 --- a/ghc/lib/std/PrelGHC.hi-boot +++ b/ghc/lib/std/PrelGHC.hi-boot @@ -46,6 +46,7 @@ __export PrelGHC takeMVarzh putMVarzh tryTakeMVarzh + tryPutMVarzh isEmptyMVarzh -- Parallel diff --git a/ghc/rts/Prelude.h b/ghc/rts/Prelude.h index 48f72e4..d251340 100644 --- a/ghc/rts/Prelude.h +++ b/ghc/rts/Prelude.h @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: Prelude.h,v 1.14 2001/02/09 13:09:16 simonmar Exp $ + * $Id: Prelude.h,v 1.15 2001/02/14 12:59:34 simonmar Exp $ * * (c) The GHC Team, 1998-2001 * @@ -67,7 +67,6 @@ extern DLL_IMPORT const StgInfoTable PrelStable_StablePtr_con_info; #define stackOverflow_closure (&PrelIOBase_stackOverflow_closure) #define heapOverflow_closure (&PrelIOBase_heapOverflow_closure) -#define PutFullMVar_closure (&PrelIOBase_PutFullMVar_closure) #define BlockedOnDeadMVar_closure (&PrelIOBase_BlockedOnDeadMVar_closure) #define NonTermination_closure (&PrelIOBase_NonTermination_closure) diff --git a/ghc/rts/PrimOps.hc b/ghc/rts/PrimOps.hc index 711f538..b6d52bc 100644 --- a/ghc/rts/PrimOps.hc +++ b/ghc/rts/PrimOps.hc @@ -1,5 +1,5 @@ /* ----------------------------------------------------------------------------- - * $Id: PrimOps.hc,v 1.71 2001/02/11 17:51:07 simonmar Exp $ + * $Id: PrimOps.hc,v 1.72 2001/02/14 12:59:34 simonmar Exp $ * * (c) The GHC Team, 1998-2000 * @@ -876,6 +876,21 @@ FN_(takeMVarzh_fast) val = mvar->value; mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure; + /* wake up the first thread on the queue + */ + if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) { + ASSERT(mvar->head->why_blocked == BlockedOnMVar); +#if defined(GRAN) || defined(PAR) + /* ToDo: check 2nd arg (mvar) is right */ + mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar); +#else + mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head); +#endif + if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) { + mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure; + } + } + /* do this last... we might have locked the MVar in the SMP case, * and writing the info pointer will unlock it. */ @@ -917,6 +932,21 @@ FN_(tryTakeMVarzh_fast) val = mvar->value; mvar->value = (StgClosure *)&stg_END_TSO_QUEUE_closure; + /* wake up the first thread on the queue + */ + if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) { + ASSERT(mvar->head->why_blocked == BlockedOnMVar); +#if defined(GRAN) || defined(PAR) + /* ToDo: check 2nd arg (mvar) is right */ + mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar); +#else + mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head); +#endif + if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) { + mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure; + } + } + /* do this last... we might have locked the MVar in the SMP case, * and writing the info pointer will unlock it. */ @@ -944,8 +974,21 @@ FN_(putMVarzh_fast) #endif if (info == &stg_FULL_MVAR_info) { - R1.cl = (StgClosure *)PutFullMVar_closure; - JMP_(raisezh_fast); + if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) { + mvar->head = CurrentTSO; + } else { + mvar->tail->link = CurrentTSO; + } + CurrentTSO->link = (StgTSO *)&stg_END_TSO_QUEUE_closure; + CurrentTSO->why_blocked = BlockedOnMVar; + CurrentTSO->block_info.closure = (StgClosure *)mvar; + mvar->tail = CurrentTSO; + +#ifdef SMP + /* unlock the MVar */ + mvar->header.info = &stg_FULL_MVAR_info; +#endif + BLOCK( R1_PTR | R2_PTR, putMVarzh_fast ); } mvar->value = R2.cl; @@ -955,10 +998,8 @@ FN_(putMVarzh_fast) */ if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) { ASSERT(mvar->head->why_blocked == BlockedOnMVar); -#if defined(GRAN) - mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar); -#elif defined(PAR) - // ToDo: check 2nd arg (mvar) is right +#if defined(GRAN) || defined(PAR) + /* ToDo: check 2nd arg (mvar) is right */ mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar); #else mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head); @@ -976,6 +1017,59 @@ FN_(putMVarzh_fast) FE_ } +FN_(tryPutMVarzh_fast) +{ + StgMVar *mvar; + const StgInfoTable *info; + + FB_ + /* args: R1 = MVar, R2 = value */ + + mvar = (StgMVar *)R1.p; + +#ifdef SMP + info = LOCK_CLOSURE(mvar); +#else + info = GET_INFO(mvar); +#endif + + if (info == &stg_FULL_MVAR_info) { + +#ifdef SMP + /* unlock the MVar */ + mvar->header.info = &stg_FULL_MVAR_info; +#endif + + /* HACK: we need a pointer to pass back, so we abuse NO_FINALIZER_closure */ + RET_N(0); + } + + mvar->value = R2.cl; + + /* wake up the first thread on the queue, it will continue with the + * takeMVar operation and mark the MVar empty again. + */ + if (mvar->head != (StgTSO *)&stg_END_TSO_QUEUE_closure) { + ASSERT(mvar->head->why_blocked == BlockedOnMVar); +#if defined(GRAN) || defined(PAR) + /* ToDo: check 2nd arg (mvar) is right */ + mvar->head = RET_STGCALL2(StgTSO *,unblockOne,mvar->head,mvar); +#else + mvar->head = RET_STGCALL1(StgTSO *,unblockOne,mvar->head); +#endif + if (mvar->head == (StgTSO *)&stg_END_TSO_QUEUE_closure) { + mvar->tail = (StgTSO *)&stg_END_TSO_QUEUE_closure; + } + } + + /* unlocks the MVar in the SMP case */ + SET_INFO(mvar,&stg_FULL_MVAR_info); + + /* ToDo: yield here for better communication performance? */ + RET_N(1); + FE_ +} + /* ----------------------------------------------------------------------------- Stable pointer primitives ------------------------------------------------------------------------- */ diff --git a/ghc/tests/concurrent/should_run/conc026.hs b/ghc/tests/concurrent/should_run/conc026.hs new file mode 100644 index 0000000..ba86bf4 --- /dev/null +++ b/ghc/tests/concurrent/should_run/conc026.hs @@ -0,0 +1,8 @@ +-- test for blocking putMVar + +import Concurrent + +main = do + m <- newMVar () + forkIO (threadDelay 100000 >> takeMVar m) + putMVar m () diff --git a/ghc/tests/concurrent/should_run/conc027.hs b/ghc/tests/concurrent/should_run/conc027.hs new file mode 100644 index 0000000..71e956e --- /dev/null +++ b/ghc/tests/concurrent/should_run/conc027.hs @@ -0,0 +1,9 @@ + +import Concurrent + +main = do + m <- newEmptyMVar + end <- newEmptyMVar + forkIO (sequence_ [ putMVar m () | _ <- [1 .. 10000] ]) + forkIO (sequence_ [ takeMVar m | _ <- [1 .. 10000] ] >> putMVar end ()) + takeMVar end -- 1.7.10.4