Commit | Line | Data |
---|---|---|
2b829bbb | 1 | /* Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006 Free Software Foundation, Inc. |
0f2d19dd | 2 | * |
73be1d9e MV |
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. | |
0f2d19dd | 7 | * |
73be1d9e MV |
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. | |
0f2d19dd | 12 | * |
73be1d9e MV |
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 | |
92205699 | 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
73be1d9e | 16 | */ |
1bbd0b84 | 17 | |
1bbd0b84 | 18 | |
0f2d19dd JB |
19 | \f |
20 | ||
a0599745 MD |
21 | #include "libguile/_scm.h" |
22 | #include "libguile/ports.h" | |
23 | #include "libguile/smob.h" | |
20e6290e | 24 | |
a0599745 MD |
25 | #include "libguile/validate.h" |
26 | #include "libguile/arbiters.h" | |
0f2d19dd JB |
27 | |
28 | \f | |
95a58b3c KR |
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 | |
32 | the store is done. | |
33 | ||
34 | The operands are scm_t_bits, fet and sto are plain variables, mem is a | |
35 | memory location (ie. an lvalue). | |
36 | ||
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. */ | |
40 | ||
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). | |
46 | ||
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 | |
52 | harmless). */ | |
53 | ||
54 | #define FETCH_STORE(fet,mem,sto) \ | |
55 | do { \ | |
56 | asm ("xchg %0, %1" \ | |
57 | : "=r" (fet), "=m" (mem) \ | |
58 | : "0" (sto), "m" (mem)); \ | |
59 | } while (0) | |
60 | #endif | |
61 | ||
62 | #ifndef FETCH_STORE | |
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. */ | |
8ff3ca46 KR |
67 | #define FETCH_STORE(fet,mem,sto) \ |
68 | do { \ | |
69 | scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); \ | |
70 | (fet) = (mem); \ | |
71 | (mem) = (sto); \ | |
72 | scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); \ | |
95a58b3c KR |
73 | } while (0) |
74 | #endif | |
9bebea88 | 75 | |
0f2d19dd | 76 | |
92c2555f | 77 | static scm_t_bits scm_tc16_arbiter; |
0f2d19dd | 78 | |
1cc91f1b | 79 | |
95a58b3c KR |
80 | #define SCM_LOCK_VAL (scm_tc16_arbiter | (1L << 16)) |
81 | #define SCM_UNLOCK_VAL scm_tc16_arbiter | |
843524cc | 82 | #define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16)) |
95a58b3c | 83 | |
c209c88e | 84 | |
0f2d19dd | 85 | static int |
e841c3e0 | 86 | arbiter_print (SCM exp, SCM port, scm_print_state *pstate) |
0f2d19dd | 87 | { |
b7f3516f | 88 | scm_puts ("#<arbiter ", port); |
c209c88e | 89 | if (SCM_ARB_LOCKED (exp)) |
b7f3516f | 90 | scm_puts ("locked ", port); |
cb87e06a | 91 | scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate); |
b7f3516f | 92 | scm_putc ('>', port); |
0f2d19dd JB |
93 | return !0; |
94 | } | |
95 | ||
3b3b36dd | 96 | SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0, |
cb87e06a | 97 | (SCM name), |
7305dd20 KR |
98 | "Return an arbiter object, initially unlocked. Currently\n" |
99 | "@var{name} is only used for diagnostic output.") | |
1bbd0b84 | 100 | #define FUNC_NAME s_scm_make_arbiter |
0f2d19dd | 101 | { |
843524cc | 102 | SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name)); |
0f2d19dd | 103 | } |
1bbd0b84 | 104 | #undef FUNC_NAME |
0f2d19dd | 105 | |
9bebea88 | 106 | |
95a58b3c KR |
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 | |
110 | semantics. */ | |
9bebea88 | 111 | |
3b3b36dd | 112 | SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0, |
cb87e06a | 113 | (SCM arb), |
7305dd20 KR |
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" | |
116 | "@code{#f}.") | |
1bbd0b84 | 117 | #define FUNC_NAME s_scm_try_arbiter |
0f2d19dd | 118 | { |
95a58b3c | 119 | scm_t_bits old; |
ae0b6bf5 | 120 | SCM_VALIDATE_SMOB (1, arb, arbiter); |
95a58b3c KR |
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); | |
0f2d19dd | 123 | } |
1bbd0b84 | 124 | #undef FUNC_NAME |
0f2d19dd JB |
125 | |
126 | ||
95a58b3c KR |
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 | |
132 | compete. */ | |
9bebea88 KR |
133 | |
134 | SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0, | |
cb87e06a | 135 | (SCM arb), |
7305dd20 KR |
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" | |
138 | "@code{#f}.\n" | |
139 | "\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" | |
142 | "release it.") | |
1bbd0b84 | 143 | #define FUNC_NAME s_scm_release_arbiter |
0f2d19dd | 144 | { |
95a58b3c | 145 | scm_t_bits old; |
ae0b6bf5 | 146 | SCM_VALIDATE_SMOB (1, arb, arbiter); |
95a58b3c KR |
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); | |
0f2d19dd | 149 | } |
1bbd0b84 | 150 | #undef FUNC_NAME |
0f2d19dd JB |
151 | |
152 | ||
1cc91f1b | 153 | |
0f2d19dd JB |
154 | void |
155 | scm_init_arbiters () | |
0f2d19dd | 156 | { |
e841c3e0 KN |
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); | |
a0599745 | 160 | #include "libguile/arbiters.x" |
0f2d19dd | 161 | } |
89e00824 ML |
162 | |
163 | /* | |
164 | Local Variables: | |
165 | c-file-style: "gnu" | |
166 | End: | |
167 | */ |