123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175 |
- #ifdef HAVE_CONFIG_H
- # include <config.h>
- #endif
- #include "libguile/_scm.h"
- #include "libguile/ports.h"
- #include "libguile/smob.h"
- #include "libguile/validate.h"
- #include "libguile/arbiters.h"
- #if defined (__GNUC__) && defined (i386) && SIZEOF_SCM_T_BITS == 4
- #define FETCH_STORE(fet,mem,sto) \
- do { \
- asm ("xchg %0, %1" \
- : "=r" (fet), "=m" (mem) \
- : "0" (sto), "m" (mem)); \
- } while (0)
- #endif
- #ifndef FETCH_STORE
- #define FETCH_STORE(fet,mem,sto) \
- do { \
- scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); \
- (fet) = (mem); \
- (mem) = (sto); \
- scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); \
- } while (0)
- #endif
- static scm_t_bits scm_tc16_arbiter;
- #define SCM_LOCK_VAL (scm_tc16_arbiter | (1L << 16))
- #define SCM_UNLOCK_VAL scm_tc16_arbiter
- #define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16))
- static int
- arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
- {
- scm_puts_unlocked ("#<arbiter ", port);
- if (SCM_ARB_LOCKED (exp))
- scm_puts_unlocked ("locked ", port);
- scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
- scm_putc_unlocked ('>', port);
- return !0;
- }
- SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0,
- (SCM name),
- "Return an arbiter object, initially unlocked. Currently\n"
- "@var{name} is only used for diagnostic output.")
- #define FUNC_NAME s_scm_make_arbiter
- {
- SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name));
- }
- #undef FUNC_NAME
- /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
- unlocked and return #t. The arbiter itself wouldn't be corrupted by
- this, but two threads both getting #t would be contrary to the intended
- semantics. */
- SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
- (SCM arb),
- "If @var{arb} is unlocked, then lock it and return @code{#t}.\n"
- "If @var{arb} is already locked, then do nothing and return\n"
- "@code{#f}.")
- #define FUNC_NAME s_scm_try_arbiter
- {
- scm_t_bits old;
- scm_t_bits *loc;
- SCM_VALIDATE_SMOB (1, arb, arbiter);
- loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0);
- FETCH_STORE (old, *loc, SCM_LOCK_VAL);
- return scm_from_bool (old == SCM_UNLOCK_VAL);
- }
- #undef FUNC_NAME
- SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
- (SCM arb),
- "If @var{arb} is locked, then unlock it and return @code{#t}.\n"
- "If @var{arb} is already unlocked, then do nothing and return\n"
- "@code{#f}.\n"
- "\n"
- "Typical usage is for the thread which locked an arbiter to\n"
- "later release it, but that's not required, any thread can\n"
- "release it.")
- #define FUNC_NAME s_scm_release_arbiter
- {
- scm_t_bits old;
- scm_t_bits *loc;
- SCM_VALIDATE_SMOB (1, arb, arbiter);
- loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0);
- FETCH_STORE (old, *loc, SCM_UNLOCK_VAL);
- return scm_from_bool (old == SCM_LOCK_VAL);
- }
- #undef FUNC_NAME
- void
- scm_init_arbiters ()
- {
- scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0);
- scm_set_smob_print (scm_tc16_arbiter, arbiter_print);
- #include "libguile/arbiters.x"
- }
|