/* -*-C-*-

$Id: intercom.c,v 9.38 2007/01/05 21:19:25 cph Exp $

Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
    1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
    2006, 2007 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
USA.

*/

/* Single-processor simulation of locking, propagating, and
   communicating stuff. */

#include "scheme.h"
#include "prims.h"
#include "locks.h"
#include "zones.h"

#ifndef COMPILE_FUTURES
#include "Error: intercom.c is useless without COMPILE_FUTURES"
#endif

/* (GLOBAL-INTERRUPT LEVEL WORK TEST)

   There are 4 global interrupt levels, level 0 (highest priority)
   being reserved for GC.  See const.h for details of the dist-
   ribution of these bits with respect to local interrupt levels.

   Force all other processors to begin executing WORK (an interrupt
   handler [procedure of two arguments]) provided that TEST returns
   true.  TEST is supplied to allow this primitive to be restarted if it
   is unable to begin because another processor wins the race to
   generate a global interrupt and makes it no longer necessary that
   this processor generate one (TEST receives no arguments).  This
   primitive returns the value of the call to TEST (i.e. non-#!FALSE if
   the interrupt was really generated), and returns only after all other
   processors have begun execution of WORK (or TEST returns false).
*/

DEFINE_PRIMITIVE ("GLOBAL-INTERRUPT", Prim_send_global_interrupt, 3, 3, 0)
{
  long Which_Level;
  SCHEME_OBJECT work;
  SCHEME_OBJECT test;
  long Saved_Zone;
  PRIMITIVE_HEADER (3);
  PRIMITIVE_CANONICALIZE_CONTEXT ();
  Which_Level = (arg_index_integer (1, 4));
  work = (ARG_REF (2));		/* Why is this being ignored? -- CPH */
  test = (ARG_REF (3));
  Save_Time_Zone (Zone_Global_Int);
  POP_PRIMITIVE_FRAME (3);
 Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
  Store_Return (RC_FINISH_GLOBAL_INT);
  exp_register = (LONG_TO_UNSIGNED_FIXNUM (Which_Level));
  Save_Cont ();
  STACK_PUSH (test);
  STACK_PUSH (STACK_FRAME_HEADER);
 Pushed ();
  Restore_Time_Zone ();
  PRIMITIVE_ABORT (PRIM_APPLY);
  /*NOTREACHED*/
}

SCHEME_OBJECT
Global_Int_Part_2 (Which_Level, Do_It)
     SCHEME_OBJECT Which_Level;
     SCHEME_OBJECT Do_It;
{
  return (Do_It);
}

DEFINE_PRIMITIVE ("PUT-WORK", Prim_put_work, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
    if (EMPTY_LIST_P (queue))
      {
	queue = (cons (EMPTY_LIST, EMPTY_LIST));
	Set_Fixed_Obj_Slot (The_Work_Queue, queue);
      }
    {
      SCHEME_OBJECT queue_tail = (PAIR_CDR (queue));
      SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), EMPTY_LIST));
      SET_PAIR_CDR (queue, new_entry);
      if (EMPTY_LIST_P (queue_tail))
	SET_PAIR_CAR (queue, new_entry);
      else
	SET_PAIR_CDR (queue_tail, new_entry);
    }
  }
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("PUT-WORK-IN-FRONT", Prim_put_work_in_front, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
    if (EMPTY_LIST_P (queue))
      {
	queue = (cons (EMPTY_LIST, EMPTY_LIST));
	Set_Fixed_Obj_Slot (The_Work_Queue, queue);
      }
    {
      SCHEME_OBJECT queue_head = (PAIR_CAR (queue));
      SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), queue_head));
      SET_PAIR_CAR (queue, new_entry);
      if (EMPTY_LIST_P (queue_head))
	SET_PAIR_CDR (queue, new_entry);
    }
  }
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("DRAIN-WORK-QUEUE!", Prim_drain_queue, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  {
    SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
    Set_Fixed_Obj_Slot (The_Work_Queue, EMPTY_LIST);
    PRIMITIVE_RETURN ((!EMPTY_LIST_P (queue)) ? (PAIR_CAR (queue)) : EMPTY_LIST);
  }
}

DEFINE_PRIMITIVE ("PEEK-AT-WORK-QUEUE", Prim_peek_queue, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  {
    fast SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
    if (EMPTY_LIST_P (queue))
      PRIMITIVE_RETURN (EMPTY_LIST);
    /* Reverse the queue and return it.
       (Why is it being reversed? -- cph) */
    {
      fast SCHEME_OBJECT this_pair = (PAIR_CAR (queue));
      fast SCHEME_OBJECT result = EMPTY_LIST;
      while (!EMPTY_LIST_P (this_pair))
	{
	  result = (cons ((PAIR_CAR (this_pair)), result));
	  this_pair = (PAIR_CDR (this_pair));
	}
      PRIMITIVE_RETURN (result);
    }
  }
}

DEFINE_PRIMITIVE ("GET-WORK", Prim_get_work, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  {
    SCHEME_OBJECT thunk = (ARG_REF (1));
    /* This gets this primitive's code which is in the expression register. */
    SCHEME_OBJECT primitive = (Registers[REGBLOCK_PRIMITIVE]);
    SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
    SCHEME_OBJECT queue_head =
      ((EMPTY_LIST_P (queue)) ? EMPTY_LIST : (PAIR_CAR (queue)));
    if (EMPTY_LIST_P (queue_head))
      {
	if (thunk == SHARP_F)
	  {
	    fprintf (stderr,
		     "\nNo work available, but some has been requested!\n");
	    Microcode_Termination (TERM_EXIT);
	  }
	PRIMITIVE_CANONICALIZE_CONTEXT ();
	POP_PRIMITIVE_FRAME (1);
      Will_Push ((2 * (STACK_ENV_EXTRA_SLOTS + 1)) + 1 + CONTINUATION_SIZE);
	/* When the thunk returns, call the primitive again.
	   If there's still no work, we lose. */
	STACK_PUSH (SHARP_F);
	STACK_PUSH (primitive);
	STACK_PUSH (STACK_FRAME_HEADER + 1);
	exp_register = SHARP_F;
	Store_Return (RC_INTERNAL_APPLY);
	Save_Cont ();
	/* Invoke the thunk. */
	STACK_PUSH (thunk);
	STACK_PUSH (STACK_FRAME_HEADER);
      Pushed ();
	PRIMITIVE_ABORT (PRIM_APPLY);
      }
    {
      SCHEME_OBJECT result = (PAIR_CAR (queue_head));
      queue_head = (PAIR_CDR (queue_head));
      SET_PAIR_CAR (queue, queue_head);
      if (EMPTY_LIST_P (queue_head))
	SET_PAIR_CDR (queue, EMPTY_LIST);
      PRIMITIVE_RETURN (result);
    }
  }
}

DEFINE_PRIMITIVE ("AWAIT-SYNCHRONY", Prim_await_sync, 1, 1, 0)
{
  PRIMITIVE_HEADER (1);
  CHECK_ARG (1, PAIR_P);
  if (! (FIXNUM_P (PAIR_CDR (ARG_REF (1)))))
    error_bad_range_arg (1);
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("N-INTERPRETERS", Prim_n_interps, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
}

DEFINE_PRIMITIVE ("MY-PROCESSOR-NUMBER", Prim_my_proc, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
}

DEFINE_PRIMITIVE ("MY-INTERPRETER-NUMBER", Prim_my_interp_number, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
}

DEFINE_PRIMITIVE ("ZERO-ZONES", Prim_zero_zones, 0, 0, 0)
{
  long i;
  PRIMITIVE_HEADER (0);
#ifdef METERING
  for (i=0; i < Max_Meters; i++)
  {
    Time_Meters[i] = 0;
  }

  Old_Time = (OS_process_clock ());
#endif
  PRIMITIVE_RETURN (UNSPECIFIC);
}

/* These are really used by GC on a true parallel machine */

DEFINE_PRIMITIVE ("GC-NEEDED?", Prim_gc_needed, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((Free + GC_Space_Needed) >= MemTop));
}

DEFINE_PRIMITIVE ("SLAVE-GC-BEFORE-SYNC", Prim_slave_before, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("SLAVE-GC-AFTER-SYNC", Prim_slave_after, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("MASTER-GC-BEFORE-SYNC", Prim_master_before, 0, 0, 0)
{
  PRIMITIVE_HEADER (0);
  PRIMITIVE_RETURN (UNSPECIFIC);
}

DEFINE_PRIMITIVE ("MASTER-GC-LOOP", Prim_master_gc, 1, 1, 0)
{
  static SCHEME_OBJECT gc_prim = SHARP_F;
  extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
  PRIMITIVE_HEADER (1);
  PRIMITIVE_CANONICALIZE_CONTEXT();
  /* This primitive caches the Scheme object for the garbage collector
     primitive so that it does not have to perform a potentially
     expensive search each time. */
  if (gc_prim == SHARP_F)
    gc_prim = (make_primitive ("GARBAGE-COLLECT", 1));
  {
    SCHEME_OBJECT argument = (ARG_REF (1));
    POP_PRIMITIVE_FRAME (1);
  Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
    STACK_PUSH (argument);
    STACK_PUSH (gc_prim);
    STACK_PUSH (STACK_FRAME_HEADER + 1);
  Pushed ();
    PRIMITIVE_ABORT (PRIM_APPLY);
  }
}
