1 /* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004 Free Software Foundation, Inc.
3 * This library is free software; you can redistribute it and/or
4 * modify it under the terms of the GNU Lesser General Public
5 * License as published by the Free Software Foundation; either
6 * version 2.1 of the License, or (at your option) any later version.
8 * This library is distributed in the hope that it will be useful,
9 * but WITHOUT ANY WARRANTY; without even the implied warranty of
10 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
11 * Lesser General Public License for more details.
13 * You should have received a copy of the GNU Lesser General Public
14 * License along with this library; if not, write to the Free Software
15 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
21 #include "libguile/_scm.h"
22 #include "libguile/ports.h"
23 #include "libguile/smob.h"
25 #include "libguile/validate.h"
26 #include "libguile/arbiters.h"
29 /* FETCH_STORE sets "fet" to the value fetched from "mem" and then stores
30 "sto" there. The fetch and store are done atomically, so once the fetch
31 has been done no other thread or processor can fetch from there before
34 The operands are scm_t_bits, fet and sto are plain variables, mem is a
35 memory location (ie. an lvalue).
37 ENHANCE-ME: Add more cpu-specifics. glibc atomicity.h has some of the
38 sort of thing required. FETCH_STORE could become some sort of
39 compare-and-store if that better suited what various cpus do. */
41 #if defined (__GNUC__) && defined (i386) && SIZEOF_SCM_T_BITS == 4
42 /* This is for i386 with the normal 32-bit scm_t_bits. The xchg instruction
43 is atomic on a single processor, and it automatically asserts the "lock"
44 bus signal so it's atomic on a multi-processor (no need for the lock
45 prefix on the instruction).
47 The mem operand is read-write but "+" is not used since old gcc
48 (eg. 2.7.2) doesn't support that. "1" for the mem input doesn't work
49 (eg. gcc 3.3) when mem is a pointer dereference like current usage below.
50 Having mem as a plain input should be ok though. It tells gcc the value
51 is live, but as an "m" gcc won't fetch it itself (though that would be
54 #define FETCH_STORE(fet,mem,sto) \
57 : "=r" (fet), "=m" (mem) \
58 : "0" (sto), "m" (mem)); \
63 /* This is a generic version, with a mutex to ensure the operation is
64 atomic. Unfortunately this approach probably makes arbiters no faster
65 than mutexes (though still using less memory of course), so some
66 CPU-specifics are highly desirable. */
67 #define FETCH_STORE(fet,mem,sto) \
69 scm_mutex_lock (&scm_i_misc_mutex); \
72 scm_mutex_unlock (&scm_i_misc_mutex); \
77 static scm_t_bits scm_tc16_arbiter
;
80 #define SCM_LOCK_VAL (scm_tc16_arbiter | (1L << 16))
81 #define SCM_UNLOCK_VAL scm_tc16_arbiter
82 #define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16))
86 arbiter_print (SCM exp
, SCM port
, scm_print_state
*pstate
)
88 scm_puts ("#<arbiter ", port
);
89 if (SCM_ARB_LOCKED (exp
))
90 scm_puts ("locked ", port
);
91 scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp
)), port
, pstate
);
96 SCM_DEFINE (scm_make_arbiter
, "make-arbiter", 1, 0, 0,
98 "Return an arbiter object, initially unlocked. Currently\n"
99 "@var{name} is only used for diagnostic output.")
100 #define FUNC_NAME s_scm_make_arbiter
102 SCM_RETURN_NEWSMOB (scm_tc16_arbiter
, SCM_UNPACK (name
));
107 /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
108 unlocked and return #t. The arbiter itself wouldn't be corrupted by
109 this, but two threads both getting #t would be contrary to the intended
112 SCM_DEFINE (scm_try_arbiter
, "try-arbiter", 1, 0, 0,
114 "If @var{arb} is unlocked, then lock it and return @code{#t}.\n"
115 "If @var{arb} is already locked, then do nothing and return\n"
117 #define FUNC_NAME s_scm_try_arbiter
120 SCM_VALIDATE_SMOB (1, arb
, arbiter
);
121 FETCH_STORE (old
, * (scm_t_bits
*) SCM_CELL_OBJECT_LOC(arb
,0), SCM_LOCK_VAL
);
122 return scm_from_bool (old
== SCM_UNLOCK_VAL
);
127 /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
128 locked and return #t. The arbiter itself wouldn't be corrupted by this,
129 but we don't want two threads both thinking they were the unlocker. The
130 intended usage is for the code which locked to be responsible for
131 unlocking, but we guarantee the return value even if multiple threads
134 SCM_DEFINE (scm_release_arbiter
, "release-arbiter", 1, 0, 0,
136 "If @var{arb} is locked, then unlock it and return @code{#t}.\n"
137 "If @var{arb} is already unlocked, then do nothing and return\n"
140 "Typical usage is for the thread which locked an arbiter to\n"
141 "later release it, but that's not required, any thread can\n"
143 #define FUNC_NAME s_scm_release_arbiter
146 SCM_VALIDATE_SMOB (1, arb
, arbiter
);
147 FETCH_STORE (old
, *(scm_t_bits
*)SCM_CELL_OBJECT_LOC(arb
,0), SCM_UNLOCK_VAL
);
148 return scm_from_bool (old
== SCM_LOCK_VAL
);
157 scm_tc16_arbiter
= scm_make_smob_type ("arbiter", 0);
158 scm_set_smob_mark (scm_tc16_arbiter
, scm_markcdr
);
159 scm_set_smob_print (scm_tc16_arbiter
, arbiter_print
);
160 #include "libguile/arbiters.x"