/* -*-C-*-
$Id: intercom.c,v 9.31 1999/01/02 06:11:34 cph Exp $
Copyright (c) 1987-1999 Massachusetts Institute of Technology
This program 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.
This program 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 this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, 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);
Store_Expression (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 (queue == EMPTY_LIST)
{
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 (queue_tail == EMPTY_LIST)
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 (queue == EMPTY_LIST)
{
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 (queue_head == EMPTY_LIST)
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 ((queue != EMPTY_LIST) ? (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 (queue == EMPTY_LIST)
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 (this_pair != EMPTY_LIST)
{
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 = (Regs [REGBLOCK_PRIMITIVE]);
SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
SCHEME_OBJECT queue_head =
((queue == EMPTY_LIST) ? EMPTY_LIST : (PAIR_CAR (queue)));
if (queue_head == EMPTY_LIST)
{
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);
Store_Expression (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 (queue_head == EMPTY_LIST)
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);
}
}
syntax highlighted by Code2HTML, v. 0.9.1