Back to index

plt-scheme  4.2.1
Classes | Functions | Variables
sema.c File Reference
#include "schpriv.h"

Go to the source code of this file.

Classes

struct  Scheme_Alarm

Functions

static Scheme_Objectmake_sema (int n, Scheme_Object **p)
static Scheme_Objectsemap (int n, Scheme_Object **p)
static Scheme_Objecthit_sema (int n, Scheme_Object **p)
static Scheme_Objectblock_sema_p (int n, Scheme_Object **p)
static Scheme_Objectblock_sema (int n, Scheme_Object **p)
static Scheme_Objectblock_sema_breakable (int n, Scheme_Object **p)
static Scheme_Objectmake_sema_repost (int n, Scheme_Object **p)
static Scheme_Objectmake_channel (int n, Scheme_Object **p)
static Scheme_Objectmake_channel_put (int n, Scheme_Object **p)
static Scheme_Objectchannel_p (int n, Scheme_Object **p)
static Scheme_Objectthread_send (int n, Scheme_Object **p)
static Scheme_Objectthread_receive (int n, Scheme_Object **p)
static Scheme_Objectthread_try_receive (int n, Scheme_Object **p)
static Scheme_Objectthread_receive_evt (int n, Scheme_Object **p)
static Scheme_Objectthread_rewind_receive (int n, Scheme_Object **p)
static Scheme_Objectmake_alarm (int n, Scheme_Object **p)
static Scheme_Objectmake_sys_idle (int n, Scheme_Object **p)
static int channel_get_ready (Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
static int channel_put_ready (Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
static int channel_syncer_ready (Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
static int alarm_ready (Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
static int always_ready (Scheme_Object *w)
static int never_ready (Scheme_Object *w)
static int thread_recv_ready (Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
static int pending_break (Scheme_Thread *p)
static int sema_ready (Scheme_Object *s)
static Scheme_Objectsema_for_repost (Scheme_Object *s, int *repost)
void scheme_init_sema (Scheme_Env *env)
Scheme_Objectscheme_make_sema (long v)
Scheme_Objectscheme_make_sema_repost (Scheme_Object *sema)
void scheme_post_sema (Scheme_Object *o)
void scheme_post_sema_all (Scheme_Object *o)
static int out_of_line (Scheme_Object *a)
static void get_into_line (Scheme_Sema *sema, Scheme_Channel_Syncer *w)
static void get_outof_line (Scheme_Sema *sema, Scheme_Channel_Syncer *w)
static void ext_get_into_line (Scheme_Object *ch, Scheme_Schedule_Info *sinfo)
void scheme_get_outof_line (Scheme_Channel_Syncer *ch_w)
static int try_channel (Scheme_Sema *sema, Syncing *syncing, int pos, Scheme_Object **result)
int scheme_try_plain_sema (Scheme_Object *o)
int scheme_wait_semas_chs (int n, Scheme_Object **o, int just_try, Syncing *syncing)
int scheme_wait_sema (Scheme_Object *o, int just_try)
Scheme_Objectscheme_make_channel ()
Scheme_Objectscheme_make_channel_put_evt (Scheme_Object *ch, Scheme_Object *v)
int scheme_try_channel_put (Scheme_Object *ch, Scheme_Object *v)
int scheme_try_channel_get (Scheme_Object *ch)
static void make_mbox_sema (Scheme_Thread *p)
static void mbox_push (Scheme_Thread *p, Scheme_Object *o)
static void mbox_push_front (Scheme_Thread *p, Scheme_Object *lst)
static Scheme_Objectmbox_pop (Scheme_Thread *p, int dec)

Variables

Scheme_Objectscheme_always_ready_evt
Scheme_Objectscheme_system_idle_channel
int scheme_main_was_once_suspended
static Scheme_Objectsystem_idle_put_evt
static Scheme_Objectthread_recv_evt

Class Documentation

struct Scheme_Alarm

Definition at line 69 of file sema.c.

Collaboration diagram for Scheme_Alarm:
Class Members
double sleep_end
Scheme_Object so

Function Documentation

static int alarm_ready ( Scheme_Object ch,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 1234 of file sema.c.

{
  Scheme_Alarm *a = (Scheme_Alarm *)_a;

  if (!sinfo->sleep_end
      || (sinfo->sleep_end > a->sleep_end))
    sinfo->sleep_end = a->sleep_end;

  if (a->sleep_end <= scheme_get_inexact_milliseconds())
    return 1;

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int always_ready ( Scheme_Object w) [static]

Definition at line 1248 of file sema.c.

{
  return 1;
}

Here is the caller graph for this function:

static Scheme_Object * block_sema ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 887 of file sema.c.

{
  if (!SCHEME_SEMAP(p[0]))
    scheme_wrong_type("semaphore-wait", "sema", 0, n, p);

  scheme_wait_sema(p[0], 0);

  /* In case a break appeared after we received the post,
     check for a break, because scheme_wait_sema() won't: */
  scheme_check_break_now();

  return scheme_void;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * block_sema_breakable ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 901 of file sema.c.

{
  if (!SCHEME_SEMAP(p[0]))
    scheme_wrong_type("semaphore-wait/enable-break", "sema", 0, n, p);

  scheme_wait_sema(p[0], -1);

  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object * block_sema_p ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 879 of file sema.c.

{
  if (!SCHEME_SEMAP(p[0]))
    scheme_wrong_type("semaphore-try-wait?", "sema", 0, n, p);

  return scheme_wait_sema(p[0], 1) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static int channel_get_ready ( Scheme_Object ch,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 995 of file sema.c.

{
  Scheme_Object *result;

  if (try_channel((Scheme_Sema *)ch, (Syncing *)sinfo->current_syncing, -1, &result)) {
    scheme_set_sync_target(sinfo, result, NULL, NULL, 0, 0, NULL);
    return 1;
  }

  ext_get_into_line(ch, sinfo);
  
  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * channel_p ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 988 of file sema.c.

{
  return (SCHEME_CHANNELP(p[0])
         ? scheme_true
         : scheme_false);
}

Here is the caller graph for this function:

static int channel_put_ready ( Scheme_Object ch,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 1009 of file sema.c.

{
  if (try_channel((Scheme_Sema *)ch, (Syncing *)sinfo->current_syncing, -1, NULL))
    return 1;

  ext_get_into_line(ch, sinfo);
  
  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int channel_syncer_ready ( Scheme_Object ch,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 1019 of file sema.c.

{
  Scheme_Channel_Syncer *w = (Scheme_Channel_Syncer *)ch_w;

  if (w->picked) {
    /* The value, if any, should have been tranferred already (in which
       case we would not have made it here, actually). */
    return 1;
  }

  return 0;
}

Here is the caller graph for this function:

static void ext_get_into_line ( Scheme_Object ch,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 472 of file sema.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static void get_into_line ( Scheme_Sema sema,
Scheme_Channel_Syncer w 
) [static]

Definition at line 389 of file sema.c.

{
  Scheme_Channel_Syncer *last, *first;
  
  w->in_line = 1;
  w->picked = 0;

  if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
    return; /* !!!! skip everything else */
  } else if (SCHEME_SEMAP(sema)) {
    last = sema->last;
    first = sema->first;
  } else if (SCHEME_CHANNELP(sema)) {
    last = ((Scheme_Channel *)sema)->get_last;
    first = ((Scheme_Channel *)sema)->get_first;
  } else {
    last = ((Scheme_Channel_Put *)sema)->ch->put_last;
    first = ((Scheme_Channel_Put *)sema)->ch->put_first;
  }

  w->prev = last;
  if (last)
    last->next = w;
  else
    first = w;
  last = w;
  w->next = NULL;

  if (SCHEME_SEMAP(sema)) {
    sema->last = last;
    sema->first = first;
  } else if (SCHEME_CHANNELP(sema)) {
    ((Scheme_Channel *)sema)->get_last = last;
    ((Scheme_Channel *)sema)->get_first = first;
  } else {
    ((Scheme_Channel_Put *)sema)->ch->put_last = last;
    ((Scheme_Channel_Put *)sema)->ch->put_first = first;
  }
}

Here is the caller graph for this function:

static void get_outof_line ( Scheme_Sema sema,
Scheme_Channel_Syncer w 
) [static]

Definition at line 430 of file sema.c.

{
  Scheme_Channel_Syncer *last, *first;

  if (!w->in_line)
    return;
  w->in_line = 0;

  if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) {
    return; /* !!!! skip everything else */
  } else if (SCHEME_SEMAP(sema)) {
    last = sema->last;
    first = sema->first;
  } else if (SCHEME_CHANNELP(sema)) {
    last = ((Scheme_Channel *)sema)->get_last;
    first = ((Scheme_Channel *)sema)->get_first;
  } else {
    last = ((Scheme_Channel_Put *)sema)->ch->put_last;
    first = ((Scheme_Channel_Put *)sema)->ch->put_first;
  }

  if (w->prev)
    w->prev->next = w->next;
  else
    first = w->next;
  if (w->next)
    w->next->prev = w->prev;
  else
    last = w->prev;

  if (SCHEME_SEMAP(sema)) {
    sema->last = last;
    sema->first = first;
  } else if (SCHEME_CHANNELP(sema)) {
    ((Scheme_Channel *)sema)->get_last = last;
    ((Scheme_Channel *)sema)->get_first = first;
  } else {
    ((Scheme_Channel_Put *)sema)->ch->put_last = last;
    ((Scheme_Channel_Put *)sema)->ch->put_first = first;
  }
}

Here is the caller graph for this function:

static Scheme_Object * hit_sema ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 346 of file sema.c.

{
  if (!SCHEME_SEMAP(p[0]))
    scheme_wrong_type("semaphore-post", "semaphore", 0, n, p);

  scheme_post_sema(p[0]);

  return scheme_void;
}

Here is the caller graph for this function:

static Scheme_Object * make_alarm ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1216 of file sema.c.

{
  Scheme_Alarm *a;
  double sleep_end;

  if (!SCHEME_REALP(argv[0])) {
    scheme_wrong_type("alarm-evt", "real number", 0, argc, argv);
  }

  sleep_end = scheme_get_val_as_double(argv[0]);

  a = MALLOC_ONE_TAGGED(Scheme_Alarm);
  a->so.type = scheme_alarm_type;
  a->sleep_end = sleep_end;

  return (Scheme_Object *)a;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * make_channel ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 950 of file sema.c.

{
  return scheme_make_channel();
}

Here is the caller graph for this function:

static Scheme_Object * make_channel_put ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 980 of file sema.c.

{
  if (!SCHEME_CHANNELP(argv[0]))
    scheme_wrong_type("channel-put-evt", "channel", 0, argc, argv);

  return scheme_make_channel_put_evt(argv[0], argv[1]);
}

Here is the caller graph for this function:

static void make_mbox_sema ( Scheme_Thread p) [static]

Definition at line 1044 of file sema.c.

{
  if (!p->mbox_sema) {
    Scheme_Object *sema = NULL;
    sema = scheme_make_sema(0); 
    p->mbox_sema = sema;
  }
}

Here is the caller graph for this function:

static Scheme_Object * make_sema ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 225 of file sema.c.

{
  long v;

  if (n) {
    if (!SCHEME_INTP(p[0])) {
      if (!SCHEME_BIGNUMP(p[0]) || !SCHEME_BIGPOS(p[0]))
       scheme_wrong_type("make-semaphore", "non-negative exact integer", 0, n, p);
    }

    if (!scheme_get_int_val(p[0], &v)) {
      scheme_raise_exn(MZEXN_FAIL,
                     "make-semaphore: starting value %s is too large",
                     scheme_make_provided_string(p[0], 0, NULL));
    } else if (v < 0)
      scheme_wrong_type("make-semaphore", "non-negative exact integer", 0, n, p);
  } else
    v = 0;

  return scheme_make_sema(v);
}

Here is the caller graph for this function:

static Scheme_Object * make_sema_repost ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 247 of file sema.c.

{
  if (!SCHEME_SEMAP(p[0]))
    scheme_wrong_type("semaphore-peek-evt", "semaphore", 0, n, p);
 
  return scheme_make_sema_repost(p[0]);
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * make_sys_idle ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1258 of file sema.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* mbox_pop ( Scheme_Thread p,
int  dec 
) [static]

Definition at line 1102 of file sema.c.

{
  /* Assertion: mbox_first != NULL */
  Scheme_Object *r = NULL;

  r = SCHEME_CAR(p->mbox_first);
  p->mbox_first = SCHEME_CDR(p->mbox_first);
  if (!p->mbox_first)
    p->mbox_last = NULL;
  
  if (dec)
    scheme_try_plain_sema(p->mbox_sema);

  return r;
}

Here is the caller graph for this function:

static void mbox_push ( Scheme_Thread p,
Scheme_Object o 
) [static]

Definition at line 1053 of file sema.c.

{
  Scheme_Object *next;

  next = scheme_make_raw_pair(o, NULL);
  
  if (p->mbox_first) {
    SCHEME_CDR(p->mbox_last) = next;
    p->mbox_last = next;
  } else {
    p->mbox_first = next;
    p->mbox_last = next;
  }

  make_mbox_sema(p);
  scheme_post_sema(p->mbox_sema);
  /* Post can't overflow the semaphore, because we'd run out of
     memory for the queue, first. */
}

Here is the call graph for this function:

Here is the caller graph for this function:

static void mbox_push_front ( Scheme_Thread p,
Scheme_Object lst 
) [static]

Definition at line 1073 of file sema.c.

{
  int cnt = -1;
  Scheme_Object *next, *hd;

  make_mbox_sema(p);

  next = lst;
  while (!SCHEME_NULLP(next)) {
    /* Push one: */
    hd = scheme_make_raw_pair(SCHEME_CAR(next), p->mbox_first);
    if (!p->mbox_first)
      p->mbox_last = hd;
    p->mbox_first = hd;

    ++cnt;
    next = SCHEME_CDR(next);

    if (SCHEME_NULLP(next) || (cnt == 256)) {
      /* Either done or need to pause to allow breaks/swaps; */
      /* do a single post for all messages so far. */
      ((Scheme_Sema*)p->mbox_sema)->value += cnt;
      scheme_post_sema(p->mbox_sema);
      SCHEME_USE_FUEL(cnt+1); /* might sleep */
      cnt = -1;
    }
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int never_ready ( Scheme_Object w) [static]

Definition at line 1253 of file sema.c.

{
  return 0;
}

Here is the caller graph for this function:

static int out_of_line ( Scheme_Object a) [static]

Definition at line 356 of file sema.c.

{
  Scheme_Thread *p;
  int n, i;
  Scheme_Channel_Syncer *w;

  /* Out of one line? */
  n = SCHEME_INT_VAL(((Scheme_Object **)a)[0]);
  for (i = 0; i < n; i++) {
    w = (((Scheme_Channel_Syncer ***)a)[1])[i];
    if (w->picked)
      return 1;
  }

  /* Suspended break? */
  p = ((Scheme_Thread **)a)[2];
  if (p->external_break) {
    int v;
    --p->suspend_break;
    v = scheme_can_break(p);
    p->suspend_break++;
    if (v)
      return 1; 
  }

  /* Suspended by user? */
  if ((p->running & MZTHREAD_USER_SUSPENDED)
      || scheme_main_was_once_suspended)
    return 1;

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int pending_break ( Scheme_Thread p) [static]

Definition at line 911 of file sema.c.

{
  if (p->running & (MZTHREAD_KILLED | MZTHREAD_USER_SUSPENDED))
    return 1;

  if (p->external_break) {
    int v;

    if (!p->next) {
      /* if p is the main thread, it must have a suspension
        to block on a channel or semaphore: */
      --p->suspend_break;
    }

    v = scheme_can_break(p);

    if (!p->next)
      p->suspend_break++;

    return v;
  }

  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 492 of file sema.c.

{
  get_outof_line((Scheme_Sema *)ch_w->obj, ch_w);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 86 of file sema.c.

{
  Scheme_Object *o;

#ifdef MZ_PRECISE_GC
  register_traversers();
#endif

  scheme_add_global_constant("make-semaphore", 
                          scheme_make_prim_w_arity(make_sema,
                                                "make-semaphore", 
                                                0, 1), 
                          env);
  scheme_add_global_constant("semaphore?", 
                          scheme_make_folding_prim(semap,
                                                "semaphore?", 
                                                1, 1, 1), 
                          env);
  scheme_add_global_constant("semaphore-post", 
                          scheme_make_prim_w_arity(hit_sema, 
                                                "semaphore-post", 
                                                1, 1), 
                          env);
  scheme_add_global_constant("semaphore-try-wait?", 
                          scheme_make_prim_w_arity(block_sema_p, 
                                                "semaphore-try-wait?", 
                                                1, 1), 
                          env);
  scheme_add_global_constant("semaphore-wait", 
                          scheme_make_prim_w_arity(block_sema, 
                                                "semaphore-wait", 
                                                1, 1), 
                          env);
  scheme_add_global_constant("semaphore-wait/enable-break", 
                          scheme_make_prim_w_arity(block_sema_breakable, 
                                                "semaphore-wait/enable-break", 
                                                1, 1), 
                          env);

  scheme_add_global_constant("semaphore-peek-evt", 
                          scheme_make_prim_w_arity(make_sema_repost,
                                                "semaphore-peek-evt", 
                                                1, 1), 
                          env);

  scheme_add_global_constant("make-channel", 
                          scheme_make_prim_w_arity(make_channel,
                                                "make-channel",
                                                0, 0), 
                          env);
  scheme_add_global_constant("channel-put-evt", 
                          scheme_make_prim_w_arity(make_channel_put,
                                                "channel-put-evt",
                                                2, 2), 
                          env);
  scheme_add_global_constant("channel?", 
                          scheme_make_folding_prim(channel_p,
                                                "channel?",
                                                1, 1, 1), 
                          env);  

  scheme_add_global_constant("thread-send", 
                          scheme_make_prim_w_arity(thread_send,
                                                "thread-send", 
                                                2, 3), 
                          env);
  scheme_add_global_constant("thread-receive", 
                          scheme_make_prim_w_arity(thread_receive,
                                                "thread-receive", 
                                                0, 0), 
                          env);
  scheme_add_global_constant("thread-try-receive", 
                          scheme_make_prim_w_arity(thread_try_receive,
                                                "thread-try-receive", 
                                                0, 0), 
                          env);
  scheme_add_global_constant("thread-receive-evt", 
                          scheme_make_prim_w_arity(thread_receive_evt,
                                                "thread-receive-evt", 
                                                0, 0), 
                          env);
  scheme_add_global_constant("thread-rewind-receive", 
                          scheme_make_prim_w_arity(thread_rewind_receive,
                                                "thread-rewind-receive", 
                                                1, 1), 
                          env);

  scheme_add_global_constant("alarm-evt", 
                          scheme_make_prim_w_arity(make_alarm,
                                                "alarm-evt",
                                                1, 1), 
                          env);

  scheme_add_global_constant("system-idle-evt", 
                          scheme_make_prim_w_arity(make_sys_idle,
                                                "system-idle-evt",
                                                0, 0), 
                          env);

  REGISTER_SO(scheme_always_ready_evt);
  scheme_always_ready_evt = scheme_alloc_small_object();
  scheme_always_ready_evt->type = scheme_always_evt_type;
  scheme_add_global_constant("always-evt", scheme_always_ready_evt, env);

  o = scheme_alloc_small_object();
  o->type = scheme_never_evt_type;
  scheme_add_global_constant("never-evt", o, env);

  REGISTER_SO(thread_recv_evt);
  o = scheme_alloc_small_object();
  o->type = scheme_thread_recv_evt_type;
  thread_recv_evt = o;

  REGISTER_SO(scheme_system_idle_channel);
  scheme_system_idle_channel = scheme_make_channel();

  scheme_add_evt(scheme_sema_type, sema_ready, NULL, NULL, 0);
  scheme_add_evt_through_sema(scheme_semaphore_repost_type, sema_for_repost, NULL);
  scheme_add_evt(scheme_channel_type, (Scheme_Ready_Fun)channel_get_ready, NULL, NULL, 1);
  scheme_add_evt(scheme_channel_put_type, (Scheme_Ready_Fun)channel_put_ready, NULL, NULL, 1);
  scheme_add_evt(scheme_channel_syncer_type, (Scheme_Ready_Fun)channel_syncer_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_alarm_type, (Scheme_Ready_Fun)alarm_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_always_evt_type, always_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_never_evt_type, never_ready, NULL, NULL, 0);
  scheme_add_evt(scheme_thread_recv_evt_type, (Scheme_Ready_Fun)thread_recv_ready, NULL, NULL, 0);
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 940 of file sema.c.

Definition at line 955 of file sema.c.

Definition at line 213 of file sema.c.

Definition at line 255 of file sema.c.

Here is the caller graph for this function:

Definition at line 271 of file sema.c.

{
  Scheme_Sema *t = (Scheme_Sema *)o;
  int v, consumed;

  if (t->value < 0) return;

  v = t->value + 1;
  if (v > t->value) {
    t->value = v;

    while (t->first) {
      Scheme_Channel_Syncer *w;

      w = t->first;

      t->first = w->next;
      if (!w->next)
       t->last = NULL;
      else
       t->first->prev = NULL;
      
      if ((!w->syncing || !w->syncing->result) && !pending_break(w->p)) {
       if (w->syncing) {
         w->syncing->result = w->syncing_i + 1;
         if (w->syncing->disable_break)
           w->syncing->disable_break->suspend_break++;
         scheme_post_syncing_nacks(w->syncing);
         if (!w->syncing->reposts || !w->syncing->reposts[w->syncing_i]) {
           t->value -= 1;
           consumed = 1;
         } else
           consumed = 0;
          if (w->syncing->accepts && w->syncing->accepts[w->syncing_i])
            scheme_accept_sync(w->syncing, w->syncing_i);
       } else {
         /* In this case, we will remove the syncer from line, but
            someone else might grab the post. This is unfair, but it
            can help improve throughput when multiple threads synchronize
            on a lock. */
         consumed = 1;
       }
       w->picked = 1;
      } else
       consumed = 0;

      w->in_line = 0;
      w->prev = NULL;
      w->next = NULL;

      if (w->picked) {
       scheme_weak_resume_thread(w->p);
       if (consumed)
         break;
      }
      /* otherwise, loop to find one we can wake up */
    }

    return;
  }

  scheme_raise_exn(MZEXN_FAIL,
                 "semaphore-post: the maximum post count has already been reached");
}

Here is the call graph for this function:

Definition at line 336 of file sema.c.

{
  Scheme_Sema *t = (Scheme_Sema *)o;

  while (t->first) {
    scheme_post_sema(o);
  }
  t->value = -1;
}

Definition at line 1032 of file sema.c.

{
  if (try_channel((Scheme_Sema *)ch, NULL, -1, NULL)) {
    return 1;
  }
  return 0;
}

Here is the call graph for this function:

Here is the caller graph for this function:

Definition at line 967 of file sema.c.

{
  if (((Scheme_Channel *)ch)->get_first) {
    Scheme_Object *a[2];
    v = scheme_make_channel_put_evt(ch, v);
    a[0] = scheme_make_integer(0);
    a[1] = v;
    v = scheme_sync_timeout(2, a);
    return SCHEME_TRUEP(v);
  } else
    return 0;
}

Definition at line 582 of file sema.c.

{
  Scheme_Sema *sema = (Scheme_Sema *)o;

  if (sema->value) {
    if (sema->value > 0)
      --sema->value;
    return 1;
  } else
    return 0;
}
int scheme_wait_sema ( Scheme_Object o,
int  just_try 
)

Definition at line 870 of file sema.c.

{
  Scheme_Object *a[1];

  a[0] = o;

  return scheme_wait_semas_chs(1, a, just_try, NULL);
}

Here is the call graph for this function:

int scheme_wait_semas_chs ( int  n,
Scheme_Object **  o,
int  just_try,
Syncing syncing 
)

Definition at line 594 of file sema.c.

{
  Scheme_Sema **semas = (Scheme_Sema **)o;
  int v, i, ii;

  if (just_try) {
    /* assert: n == 1, !syncing */
    Scheme_Sema *sema = semas[0];
    if (just_try > 0) {
      if (sema->so.type == scheme_sema_type) {
        v = scheme_try_plain_sema((Scheme_Object *)sema);
      } else {
       v = try_channel(sema, syncing, 0, NULL);
      }
    } else {
      Scheme_Cont_Frame_Data cframe;

      scheme_push_break_enable(&cframe, 1, 1);

      scheme_wait_sema((Scheme_Object *)sema, 0);

      scheme_pop_break_enable(&cframe, 0);

      return 1;
    }
  } else {
    int start_pos;

    if (n > 1) {
      if (syncing)
       start_pos = syncing->start_pos;
      else {
       Scheme_Object *rand_state;
       rand_state = scheme_get_param(scheme_current_config(), MZCONFIG_SCHEDULER_RANDOM_STATE);
       start_pos = scheme_rand((Scheme_Random_State *)rand_state);
      }
    } else
      start_pos = 0;

    /* Initial poll */
    i = 0;
    for (ii = 0; ii < n; ii++) {
      /* Randomized start position for poll ensures fairness: */
      i = (start_pos + ii) % n;

      if (semas[i]->so.type == scheme_sema_type) {
       if (semas[i]->value) {
         if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i]))
           --semas[i]->value;
          if (syncing && syncing->accepts && syncing->accepts[i])
            scheme_accept_sync(syncing, i);
         break;
       }
      } else if (semas[i]->so.type == scheme_never_evt_type) {
       /* Never ready. */
      } else if (semas[i]->so.type == scheme_channel_syncer_type) {
       /* Probably no need to poll */
      } else if (try_channel(semas[i], syncing, i, NULL))
       break;
    }

    /* In the following, syncers get changed back to channels,
       and channel puts */
    if (ii >= n) {
      Scheme_Channel_Syncer **ws, *w;

      ws = MALLOC_N(Scheme_Channel_Syncer*, n);
      for (i = 0; i < n; i++) {
       if (semas[i]->so.type == scheme_channel_syncer_type) {
         ws[i] = (Scheme_Channel_Syncer *)semas[i];
         semas[i] = (Scheme_Sema *)ws[i]->obj;
       } else {
         w = MALLOC_ONE_RT(Scheme_Channel_Syncer);
         ws[i] = w;
         w->so.type = scheme_channel_syncer_type;
         w->p = scheme_current_thread;
         w->syncing = syncing;
         w->obj = (Scheme_Object *)semas[i];
         w->syncing_i = i;
       }
      }
      
      while (1) {
       int out_of_a_line;

       /* Get into line */
       for (i = 0; i < n; i++) {
         if (!ws[i]->in_line) {
           get_into_line(semas[i], ws[i]);
         }
       }

       if (!scheme_current_thread->next) {
         void **a;

         /* We're not allowed to suspend the main thread. Delay
            breaks so we get a chance to clean up. */
         scheme_current_thread->suspend_break++;

         a = MALLOC_N(void*, 3);
         a[0] = scheme_make_integer(n);
         a[1] = ws;
         a[2] = scheme_current_thread;
         
         scheme_main_was_once_suspended = 0;

         scheme_block_until(out_of_line, NULL, (Scheme_Object *)a, (float)0.0);
         
         --scheme_current_thread->suspend_break;
       } else {
         /* Mark the thread to indicate that we need to clean up
            if the thread is killed. */
         int old_nkc;
         old_nkc = (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP);
         if (!old_nkc)
           scheme_current_thread->running += MZTHREAD_NEED_KILL_CLEANUP;
         scheme_weak_suspend_thread(scheme_current_thread);
         if (!old_nkc && (scheme_current_thread->running & MZTHREAD_NEED_KILL_CLEANUP))
           scheme_current_thread->running -= MZTHREAD_NEED_KILL_CLEANUP;
       }

       /* We've been resumed. But was it for the semaphore, or a signal? */
       out_of_a_line = 0;
       
       /* If we get the post, we must return WITHOUT BLOCKING. 
          MrEd, for example, depends on this special property, which ensures
          that the thread can't be broken or killed between
          receiving the post and returning. */

       if (!syncing) {
         /* Poster can't be sure that we really will get it,
            so we have to decrement the sema count here. */
         i = 0;
         for (ii = 0; ii < n; ii++) {
           i = (start_pos + ii) % n;
           if (ws[i]->picked) {
             out_of_a_line = 1;
             if (semas[i]->value) {
              if (semas[i]->value > 0)
                --(semas[i]->value);
              break;
             }
           }
         }
         if (ii >= n)
           i = n;
       } else {
         if (syncing->result) {
           out_of_a_line = 1;
           i = syncing->result - 1;
         } else {
           out_of_a_line = 0;
           i = n;
         }
       }

       if (!out_of_a_line) {
         /* We weren't woken by any semaphore/channel. Get out of line, block once 
            (to handle breaks/kills) and then loop to get back into line. */
         for (i = 0; i < n; i++) {
           if (ws[i]->in_line)
             get_outof_line(semas[i], ws[i]);
         }
         
         scheme_thread_block(0); /* ok if it returns multiple times */ 
         scheme_current_thread->ran_some = 1;
         /* [but why would it return multiple times?! there must have been a reason...] */
       } else {

         if ((scheme_current_thread->running & MZTHREAD_KILLED)
             || ((scheme_current_thread->running & MZTHREAD_USER_SUSPENDED)
                && !(scheme_current_thread->running & MZTHREAD_NEED_SUSPEND_CLEANUP))) {
           /* We've been killed or suspended! */
           i = -1;
         }

         /* We got a post from semas[i], or we were killed. 
            Did any (other) semaphore pick us?
            (This only happens when syncing == NULL.) */
         if (!syncing) {
           int j;

           for (j = 0; j < n; j++) {
             if (j != i) {
              if (ws[j]->picked) {
                if (semas[j]->value) {
                  /* Consume the value and repost, because no one else
                     has been told to go, and we're accepting a different post. */
                  if (semas[j]->value > 0)
                    --semas[j]->value;
                  scheme_post_sema((Scheme_Object *)semas[j]);
                }
              }
             }
           }
         }

         /* If we're done, get out of all lines that we're still in. */
         if (i < n) {
           int j;
           for (j = 0; j < n; j++) {
             if (ws[j]->in_line)
              get_outof_line(semas[j], ws[j]);
           }
         }

         if (i == -1) {
           scheme_thread_block(0); /* dies or suspends */
           scheme_current_thread->ran_some = 1;
         }

         if (i < n)
           break;
       }

       /* Otherwise: !syncing and someone stole the post, or we were
          suspended and we have to start over. Either way, poll then
          loop to get back in line an try again. */
       for (ii = 0; ii < n; ii++) {
         i = (start_pos + ii) % n;

         if (semas[i]->so.type == scheme_sema_type) {
           if (semas[i]->value) {
             if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i]))
              --semas[i]->value;
              if (syncing && syncing->accepts && syncing->accepts[i])
                scheme_accept_sync(syncing, i);
             break;
           }
         }  else if (semas[i]->so.type == scheme_never_evt_type) {
           /* Never ready. */
         } else if (try_channel(semas[i], syncing, i, NULL))
           break;
       }

       if (ii < n) {
         /* Get out of any line that we still might be in: */
         int j;
         for (j = 0; j < n; j++) {
           if (ws[j]->in_line)
             get_outof_line(semas[j], ws[j]);
         }

         break;
       }

       if (!syncing) {
         /* Looks like this thread is a victim of unfair semaphore access.
            Go into fair mode by allocating a syncing: */
         syncing = MALLOC_ONE_RT(Syncing);
#ifdef MZTAG_REQUIRED
         syncing->type = scheme_rt_syncing;
#endif
         syncing->start_pos = start_pos;

         /* Get out of all lines, and set syncing field before we get back in line: */
         {
           int j;
           for (j = 0; j < n; j++) {
             if (ws[j]->in_line)
              get_outof_line(semas[j], ws[j]);
             ws[j]->syncing = syncing;
           }
         }
       }
       /* Back to top of loop to sync again */
      }
    }
    v = i + 1;
  }

  return v;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object* sema_for_repost ( Scheme_Object s,
int repost 
) [static]

Definition at line 80 of file sema.c.

{
  *repost = 1;
  return SCHEME_PTR_VAL(s);
}

Here is the caller graph for this function:

static int sema_ready ( Scheme_Object s) [static]

Definition at line 75 of file sema.c.

{
  return scheme_wait_sema(s, 1);
}

Here is the caller graph for this function:

static Scheme_Object * semap ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 266 of file sema.c.

{
  return SCHEME_SEMAP(p[0]) ? scheme_true : scheme_false;
}

Here is the caller graph for this function:

static Scheme_Object * thread_receive ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1147 of file sema.c.

{
  /* The mbox semaphore can only be downed by the current thread, so
     receive/try-receive can directly dec+pop without syncing 
     (by calling mbox_pop with dec=1). */
  if (scheme_current_thread->mbox_first) {
    return mbox_pop(scheme_current_thread, 1);
  } else {
    Scheme_Object *v;
    Scheme_Thread *p = scheme_current_thread;

    make_mbox_sema(p);

    scheme_wait_sema(p->mbox_sema, 0);
    /* We're relying on atomicity of return after wait succeeds to ensure
       that a semaphore wait guarantees a mailbox dequeue. */
    v = mbox_pop(p, 0);
    
    /* Due to that atomicity, though, we're obliged to check for
       a break at this point: */
    scheme_check_break_now();
    
    return v;
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * thread_receive_evt ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1181 of file sema.c.

{
  return thread_recv_evt;
}

Here is the caller graph for this function:

static int thread_recv_ready ( Scheme_Object ch,
Scheme_Schedule_Info sinfo 
) [static]

Definition at line 1186 of file sema.c.

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * thread_rewind_receive ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1201 of file sema.c.

{
  if (scheme_is_list(argv[0])) {
    mbox_push_front(scheme_current_thread, argv[0]);
    return scheme_void;
  } else
    scheme_wrong_type("thread-rewind", "list", 0, argc, argv);

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * thread_send ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1118 of file sema.c.

{
  if (SCHEME_THREADP(argv[0])) {
    int running;

    if (argc > 2) {
      if (!SCHEME_FALSEP(argv[2])) /* redundant, but keeps it fast as possible */
        scheme_check_proc_arity2("thread-send", 0, 2, argc, argv, 1);
    }

    running = ((Scheme_Thread*)argv[0])->running;
    if (MZTHREAD_STILL_RUNNING(running)) {
      mbox_push((Scheme_Thread*)argv[0], argv[1]);
      return scheme_void;
    } else {
      if (argc > 2) {
        if (SCHEME_FALSEP(argv[2]))
          return scheme_false;
        else
          return _scheme_tail_apply(argv[2], 0, NULL);
      } else
        scheme_raise_exn(MZEXN_FAIL_CONTRACT, "thread-send: target thread is not running");
    }
  } else 
    scheme_wrong_type("thread-send", "thread", 0, argc, argv);

  return NULL;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static Scheme_Object * thread_try_receive ( int  n,
Scheme_Object **  p 
) [static]

Definition at line 1173 of file sema.c.

{
  if (scheme_current_thread->mbox_first)
    return mbox_pop(scheme_current_thread, 1);
  else
    return scheme_false;
}

Here is the call graph for this function:

Here is the caller graph for this function:

static int try_channel ( Scheme_Sema sema,
Syncing syncing,
int  pos,
Scheme_Object **  result 
) [static]

Definition at line 497 of file sema.c.

{
  if (SCHEME_CHANNELP(sema)) {
    /* GET mode */
    Scheme_Channel *ch = (Scheme_Channel *)sema;
    Scheme_Channel_Syncer *w = ch->put_first, *next;
    int picked = 0;

    while (w) {
      if (w->syncing == syncing) {
       /* can't synchronize with self */
       w = w->next;
      } else {
       Scheme_Channel_Put *chp = (Scheme_Channel_Put *)w->obj;

        if (!w->syncing->result && !pending_break(w->p)) {
         w->picked = 1;
         w->syncing->result = w->syncing_i + 1;
         if (w->syncing->disable_break)
           w->syncing->disable_break->suspend_break++;
         scheme_post_syncing_nacks(w->syncing);
         if (result)
           *result = chp->val;
         if (syncing && (pos >= 0)) {
           syncing->result = pos + 1;
           if (syncing->disable_break)
             syncing->disable_break->suspend_break++;
           scheme_post_syncing_nacks(syncing);
           syncing->set->argv[pos] = chp->val;
         }
         picked = 1;
         scheme_weak_resume_thread(w->p);
       }
       
       next = w->next;
       get_outof_line((Scheme_Sema *)chp, w);
       w = next;
       
       if (picked)
         return 1;
      }
    }

    return 0;
  } else {
    /* PUT mode */
    Scheme_Channel_Put *chp = (Scheme_Channel_Put *)sema;
    Scheme_Channel_Syncer *w = chp->ch->get_first, *next;
    int picked = 0;

    while (w) {
      if (w->syncing == syncing) {
       /* can't synchronize with self */
       w = w->next;
      } else {
       if (!w->syncing->result && !pending_break(w->p)) {
         w->picked = 1;
         w->syncing->set->argv[w->syncing_i] = chp->val;
         w->syncing->result = w->syncing_i + 1;
         if (w->syncing->disable_break)
           w->syncing->disable_break->suspend_break++;
         scheme_post_syncing_nacks(w->syncing);
         if (syncing && (pos >= 0)) {
           syncing->result = pos + 1;
           if (syncing->disable_break)
             syncing->disable_break->suspend_break++;
           scheme_post_syncing_nacks(syncing);
         }
         picked = 1;
         scheme_weak_resume_thread(w->p);
       }
       
       next = w->next;
       get_outof_line((Scheme_Sema *)chp->ch, w);
       w = next;
       
       if (picked)
         return 1;
      }
    }

    return 0;    
  }
}

Here is the call graph for this function:

Here is the caller graph for this function:


Variable Documentation

Definition at line 26 of file sema.c.

Definition at line 60 of file sema.c.

Definition at line 27 of file sema.c.

Definition at line 62 of file sema.c.

Definition at line 63 of file sema.c.