guile18/libguile/arbiters.c

   1 /*      Copyright (C) 1995,1996, 1997, 2000, 2001, 2004, 2005, 2006, 2008 Free Software Foundation, Inc.
   2  *
   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.
   7  *
   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.
  12  *
  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., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18
  19 \f
  20 #ifdef HAVE_CONFIG_H
  21 # include <config.h>
  22 #endif
  23
  24 #include "libguile/_scm.h"
  25 #include "libguile/ports.h"
  26 #include "libguile/smob.h"
  27
  28 #include "libguile/validate.h"
  29 #include "libguile/arbiters.h"
  30
  31 \f
  32 /* FETCH_STORE sets "fet" to the value fetched from "mem" and then stores
  33    "sto" there.  The fetch and store are done atomically, so once the fetch
  34    has been done no other thread or processor can fetch from there before
  35    the store is done.
  36
  37    The operands are scm_t_bits, fet and sto are plain variables, mem is a
  38    memory location (ie. an lvalue).
  39
  40    ENHANCE-ME: Add more cpu-specifics.  glibc atomicity.h has some of the
  41    sort of thing required.  FETCH_STORE could become some sort of
  42    compare-and-store if that better suited what various cpus do.  */
  43
  44 #if defined (__GNUC__) && defined (i386) && SIZEOF_SCM_T_BITS == 4
  45 /* This is for i386 with the normal 32-bit scm_t_bits.  The xchg instruction
  46    is atomic on a single processor, and it automatically asserts the "lock"
  47    bus signal so it's atomic on a multi-processor (no need for the lock
  48    prefix on the instruction).
  49
  50    The mem operand is read-write but "+" is not used since old gcc
  51    (eg. 2.7.2) doesn't support that.  "1" for the mem input doesn't work
  52    (eg. gcc 3.3) when mem is a pointer dereference like current usage below.
  53    Having mem as a plain input should be ok though.  It tells gcc the value
  54    is live, but as an "m" gcc won't fetch it itself (though that would be
  55    harmless).  */
  56
  57 #define FETCH_STORE(fet,mem,sto)                \
  58   do {                                          \
  59     asm ("xchg %0, %1"                          \
  60          : "=r" (fet), "=m" (mem)               \
  61          : "0"  (sto), "m"  (mem));             \
  62   } while (0)
  63 #endif
  64
  65 #ifndef FETCH_STORE
  66 /* This is a generic version, with a mutex to ensure the operation is
  67    atomic.  Unfortunately this approach probably makes arbiters no faster
  68    than mutexes (though still using less memory of course), so some
  69    CPU-specifics are highly desirable.  */
  70 #define FETCH_STORE(fet,mem,sto)                        \
  71   do {                                                  \
  72     scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex);   \
  73     (fet) = (mem);                                      \
  74     (mem) = (sto);                                      \
  75     scm_i_pthread_mutex_unlock (&scm_i_misc_mutex);     \
  76   } while (0)
  77 #endif
  78
  79
  80 static scm_t_bits scm_tc16_arbiter;
  81
  82
  83 #define SCM_LOCK_VAL         (scm_tc16_arbiter | (1L << 16))
  84 #define SCM_UNLOCK_VAL       scm_tc16_arbiter
  85 #define SCM_ARB_LOCKED(arb)  ((SCM_CELL_WORD_0 (arb)) & (1L << 16))
  86
  87
  88 static int
  89 arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
  90 {
  91   scm_puts ("#<arbiter ", port);
  92   if (SCM_ARB_LOCKED (exp))
  93     scm_puts ("locked ", port);
  94   scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
  95   scm_putc ('>', port);
  96   return !0;
  97 }
  98
  99 SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0,
 100             (SCM name),
 101             "Return an arbiter object, initially unlocked.  Currently\n"
 102             "@var{name} is only used for diagnostic output.")
 103 #define FUNC_NAME s_scm_make_arbiter
 104 {
 105   SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name));
 106 }
 107 #undef FUNC_NAME
 108
 109
 110 /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
 111    unlocked and return #t.  The arbiter itself wouldn't be corrupted by
 112    this, but two threads both getting #t would be contrary to the intended
 113    semantics.  */
 114
 115 SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
 116             (SCM arb),
 117             "If @var{arb} is unlocked, then lock it and return @code{#t}.\n"
 118             "If @var{arb} is already locked, then do nothing and return\n"
 119             "@code{#f}.")
 120 #define FUNC_NAME s_scm_try_arbiter
 121 {
 122   scm_t_bits old;
 123   SCM_VALIDATE_SMOB (1, arb, arbiter);
 124   FETCH_STORE (old, * (scm_t_bits *) SCM_CELL_OBJECT_LOC(arb,0), SCM_LOCK_VAL);
 125   return scm_from_bool (old == SCM_UNLOCK_VAL);
 126 }
 127 #undef FUNC_NAME
 128
 129
 130 /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
 131    locked and return #t.  The arbiter itself wouldn't be corrupted by this,
 132    but we don't want two threads both thinking they were the unlocker.  The
 133    intended usage is for the code which locked to be responsible for
 134    unlocking, but we guarantee the return value even if multiple threads
 135    compete.  */
 136
 137 SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
 138             (SCM arb),
 139             "If @var{arb} is locked, then unlock it and return @code{#t}.\n"
 140             "If @var{arb} is already unlocked, then do nothing and return\n"
 141             "@code{#f}.\n"
 142             "\n"
 143             "Typical usage is for the thread which locked an arbiter to\n"
 144             "later release it, but that's not required, any thread can\n"
 145             "release it.")
 146 #define FUNC_NAME s_scm_release_arbiter
 147 {
 148   scm_t_bits old;
 149   SCM_VALIDATE_SMOB (1, arb, arbiter);
 150   FETCH_STORE (old, *(scm_t_bits*)SCM_CELL_OBJECT_LOC(arb,0), SCM_UNLOCK_VAL);
 151   return scm_from_bool (old == SCM_LOCK_VAL);
 152 }
 153 #undef FUNC_NAME
 154
 155
 156
 157 void
 158 scm_init_arbiters ()
 159 {
 160   scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0);
 161   scm_set_smob_mark (scm_tc16_arbiter, scm_markcdr);
 162   scm_set_smob_print (scm_tc16_arbiter, arbiter_print);
 163 #include "libguile/arbiters.x"
 164 }
 165
 166 /*
 167   Local Variables:
 168   c-file-style: "gnu"
 169   End:
 170 */