home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / intercom.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  9KB  |  296 lines
  1. /* -*-C-*-
  2.  
  3. $Id: intercom.c,v 9.31 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. /* Single-processor simulation of locking, propagating, and
  23.    communicating stuff. */
  24.  
  25. #include "scheme.h"
  26. #include "prims.h"
  27. #include "locks.h"
  28. #include "zones.h"
  29.  
  30. #ifndef COMPILE_FUTURES
  31. #include "Error: intercom.c is useless without COMPILE_FUTURES"
  32. #endif
  33.  
  34. /* (GLOBAL-INTERRUPT LEVEL WORK TEST)
  35.  
  36.    There are 4 global interrupt levels, level 0 (highest priority)
  37.    being reserved for GC.  See const.h for details of the dist-
  38.    ribution of these bits with respect to local interrupt levels.
  39.  
  40.    Force all other processors to begin executing WORK (an interrupt
  41.    handler [procedure of two arguments]) provided that TEST returns
  42.    true.  TEST is supplied to allow this primitive to be restarted if it
  43.    is unable to begin because another processor wins the race to
  44.    generate a global interrupt and makes it no longer necessary that
  45.    this processor generate one (TEST receives no arguments).  This
  46.    primitive returns the value of the call to TEST (i.e. non-#!FALSE if
  47.    the interrupt was really generated), and returns only after all other
  48.    processors have begun execution of WORK (or TEST returns false).
  49. */
  50.  
  51. DEFINE_PRIMITIVE ("GLOBAL-INTERRUPT", Prim_send_global_interrupt, 3, 3, 0)
  52. {
  53.   long Which_Level;
  54.   SCHEME_OBJECT work;
  55.   SCHEME_OBJECT test;
  56.   long Saved_Zone;
  57.   PRIMITIVE_HEADER (3);
  58.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  59.   Which_Level = (arg_index_integer (1, 4));
  60.   work = (ARG_REF (2));        /* Why is this being ignored? -- CPH */
  61.   test = (ARG_REF (3));
  62.   Save_Time_Zone (Zone_Global_Int);
  63.   POP_PRIMITIVE_FRAME (3);
  64.  Will_Push (CONTINUATION_SIZE + STACK_ENV_EXTRA_SLOTS + 1);
  65.   Store_Return (RC_FINISH_GLOBAL_INT);
  66.   Store_Expression (LONG_TO_UNSIGNED_FIXNUM (Which_Level));
  67.   Save_Cont ();
  68.   STACK_PUSH (test);
  69.   STACK_PUSH (STACK_FRAME_HEADER);
  70.  Pushed ();
  71.   Restore_Time_Zone ();
  72.   PRIMITIVE_ABORT (PRIM_APPLY);
  73.   /*NOTREACHED*/
  74. }
  75.  
  76. SCHEME_OBJECT
  77. Global_Int_Part_2 (Which_Level, Do_It)
  78.      SCHEME_OBJECT Which_Level;
  79.      SCHEME_OBJECT Do_It;
  80. {
  81.   return (Do_It);
  82. }
  83.  
  84. DEFINE_PRIMITIVE ("PUT-WORK", Prim_put_work, 1, 1, 0)
  85. {
  86.   PRIMITIVE_HEADER (1);
  87.   {
  88.     SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
  89.     if (queue == EMPTY_LIST)
  90.       {
  91.     queue = (cons (EMPTY_LIST, EMPTY_LIST));
  92.     Set_Fixed_Obj_Slot (The_Work_Queue, queue);
  93.       }
  94.     {
  95.       SCHEME_OBJECT queue_tail = (PAIR_CDR (queue));
  96.       SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), EMPTY_LIST));
  97.       SET_PAIR_CDR (queue, new_entry);
  98.       if (queue_tail == EMPTY_LIST)
  99.     SET_PAIR_CAR (queue, new_entry);
  100.       else
  101.     SET_PAIR_CDR (queue_tail, new_entry);
  102.     }
  103.   }
  104.   PRIMITIVE_RETURN (UNSPECIFIC);
  105. }
  106.  
  107. DEFINE_PRIMITIVE ("PUT-WORK-IN-FRONT", Prim_put_work_in_front, 1, 1, 0)
  108. {
  109.   PRIMITIVE_HEADER (1);
  110.   {
  111.     SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
  112.     if (queue == EMPTY_LIST)
  113.       {
  114.     queue = (cons (EMPTY_LIST, EMPTY_LIST));
  115.     Set_Fixed_Obj_Slot (The_Work_Queue, queue);
  116.       }
  117.     {
  118.       SCHEME_OBJECT queue_head = (PAIR_CAR (queue));
  119.       SCHEME_OBJECT new_entry = (cons ((ARG_REF (1)), queue_head));
  120.       SET_PAIR_CAR (queue, new_entry);
  121.       if (queue_head == EMPTY_LIST)
  122.     SET_PAIR_CDR (queue, new_entry);
  123.     }
  124.   }
  125.   PRIMITIVE_RETURN (UNSPECIFIC);
  126. }
  127.  
  128. DEFINE_PRIMITIVE ("DRAIN-WORK-QUEUE!", Prim_drain_queue, 0, 0, 0)
  129. {
  130.   PRIMITIVE_HEADER (0);
  131.   {
  132.     SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
  133.     Set_Fixed_Obj_Slot (The_Work_Queue, EMPTY_LIST);
  134.     PRIMITIVE_RETURN ((queue != EMPTY_LIST) ? (PAIR_CAR (queue)) : EMPTY_LIST);
  135.   }
  136. }
  137.  
  138. DEFINE_PRIMITIVE ("PEEK-AT-WORK-QUEUE", Prim_peek_queue, 0, 0, 0)
  139. {
  140.   PRIMITIVE_HEADER (0);
  141.   {
  142.     fast SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
  143.     if (queue == EMPTY_LIST)
  144.       PRIMITIVE_RETURN (EMPTY_LIST);
  145.     /* Reverse the queue and return it.
  146.        (Why is it being reversed? -- cph) */
  147.     {
  148.       fast SCHEME_OBJECT this_pair = (PAIR_CAR (queue));
  149.       fast SCHEME_OBJECT result = EMPTY_LIST;
  150.       while (this_pair != EMPTY_LIST)
  151.     {
  152.       result = (cons ((PAIR_CAR (this_pair)), result));
  153.       this_pair = (PAIR_CDR (this_pair));
  154.     }
  155.       PRIMITIVE_RETURN (result);
  156.     }
  157.   }
  158. }
  159.  
  160. DEFINE_PRIMITIVE ("GET-WORK", Prim_get_work, 1, 1, 0)
  161. {
  162.   PRIMITIVE_HEADER (1);
  163.   {
  164.     SCHEME_OBJECT thunk = (ARG_REF (1));
  165.     /* This gets this primitive's code which is in the expression register. */
  166.     SCHEME_OBJECT primitive = (Regs [REGBLOCK_PRIMITIVE]);
  167.     SCHEME_OBJECT queue = (Get_Fixed_Obj_Slot (The_Work_Queue));
  168.     SCHEME_OBJECT queue_head =
  169.       ((queue == EMPTY_LIST) ? EMPTY_LIST : (PAIR_CAR (queue)));
  170.     if (queue_head == EMPTY_LIST)
  171.       {
  172.     if (thunk == SHARP_F)
  173.       {
  174.         fprintf (stderr,
  175.              "\nNo work available, but some has been requested!\n");
  176.         Microcode_Termination (TERM_EXIT);
  177.       }
  178.     PRIMITIVE_CANONICALIZE_CONTEXT ();
  179.     POP_PRIMITIVE_FRAME (1);
  180.       Will_Push ((2 * (STACK_ENV_EXTRA_SLOTS + 1)) + 1 + CONTINUATION_SIZE);
  181.     /* When the thunk returns, call the primitive again.
  182.        If there's still no work, we lose. */
  183.     STACK_PUSH (SHARP_F);
  184.     STACK_PUSH (primitive);
  185.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  186.     Store_Expression (SHARP_F);
  187.     Store_Return (RC_INTERNAL_APPLY);
  188.     Save_Cont ();
  189.     /* Invoke the thunk. */
  190.     STACK_PUSH (thunk);
  191.     STACK_PUSH (STACK_FRAME_HEADER);
  192.       Pushed ();
  193.     PRIMITIVE_ABORT (PRIM_APPLY);
  194.       }
  195.     {
  196.       SCHEME_OBJECT result = (PAIR_CAR (queue_head));
  197.       queue_head = (PAIR_CDR (queue_head));
  198.       SET_PAIR_CAR (queue, queue_head);
  199.       if (queue_head == EMPTY_LIST)
  200.     SET_PAIR_CDR (queue, EMPTY_LIST);
  201.       PRIMITIVE_RETURN (result);
  202.     }
  203.   }
  204. }
  205.  
  206. DEFINE_PRIMITIVE ("AWAIT-SYNCHRONY", Prim_await_sync, 1, 1, 0)
  207. {
  208.   PRIMITIVE_HEADER (1);
  209.   CHECK_ARG (1, PAIR_P);
  210.   if (! (FIXNUM_P (PAIR_CDR (ARG_REF (1)))))
  211.     error_bad_range_arg (1);
  212.   PRIMITIVE_RETURN (UNSPECIFIC);
  213. }
  214.  
  215. DEFINE_PRIMITIVE ("N-INTERPRETERS", Prim_n_interps, 0, 0, 0)
  216. {
  217.   PRIMITIVE_HEADER (0);
  218.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (1));
  219. }
  220.  
  221. DEFINE_PRIMITIVE ("MY-PROCESSOR-NUMBER", Prim_my_proc, 0, 0, 0)
  222. {
  223.   PRIMITIVE_HEADER (0);
  224.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
  225. }
  226.  
  227. DEFINE_PRIMITIVE ("MY-INTERPRETER-NUMBER", Prim_my_interp_number, 0, 0, 0)
  228. {
  229.   PRIMITIVE_HEADER (0);
  230.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (0));
  231. }
  232.  
  233. DEFINE_PRIMITIVE ("ZERO-ZONES", Prim_zero_zones, 0, 0, 0)
  234. {
  235.   long i;
  236.   PRIMITIVE_HEADER (0);
  237. #ifdef METERING
  238.   for (i=0; i < Max_Meters; i++)
  239.   {
  240.     Time_Meters[i] = 0;
  241.   }
  242.  
  243.   Old_Time = (OS_process_clock ());
  244. #endif
  245.   PRIMITIVE_RETURN (UNSPECIFIC);
  246. }
  247.  
  248. /* These are really used by GC on a true parallel machine */
  249.  
  250. DEFINE_PRIMITIVE ("GC-NEEDED?", Prim_gc_needed, 0, 0, 0)
  251. {
  252.   PRIMITIVE_HEADER (0);
  253.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((Free + GC_Space_Needed) >= MemTop));
  254. }
  255.  
  256. DEFINE_PRIMITIVE ("SLAVE-GC-BEFORE-SYNC", Prim_slave_before, 0, 0, 0)
  257. {
  258.   PRIMITIVE_HEADER (0);
  259.   PRIMITIVE_RETURN (UNSPECIFIC);
  260. }
  261.  
  262. DEFINE_PRIMITIVE ("SLAVE-GC-AFTER-SYNC", Prim_slave_after, 0, 0, 0)
  263. {
  264.   PRIMITIVE_HEADER (0);
  265.   PRIMITIVE_RETURN (UNSPECIFIC);
  266. }
  267.  
  268. DEFINE_PRIMITIVE ("MASTER-GC-BEFORE-SYNC", Prim_master_before, 0, 0, 0)
  269. {
  270.   PRIMITIVE_HEADER (0);
  271.   PRIMITIVE_RETURN (UNSPECIFIC);
  272. }
  273.  
  274. DEFINE_PRIMITIVE ("MASTER-GC-LOOP", Prim_master_gc, 1, 1, 0)
  275. {
  276.   static SCHEME_OBJECT gc_prim = SHARP_F;
  277.   extern SCHEME_OBJECT EXFUN (make_primitive, (char *, int));
  278.   PRIMITIVE_HEADER (1);
  279.   PRIMITIVE_CANONICALIZE_CONTEXT();
  280.   /* This primitive caches the Scheme object for the garbage collector
  281.      primitive so that it does not have to perform a potentially
  282.      expensive search each time. */
  283.   if (gc_prim == SHARP_F)
  284.     gc_prim = (make_primitive ("GARBAGE-COLLECT", 1));
  285.   {
  286.     SCHEME_OBJECT argument = (ARG_REF (1));
  287.     POP_PRIMITIVE_FRAME (1);
  288.   Will_Push (STACK_ENV_EXTRA_SLOTS + 2);
  289.     STACK_PUSH (argument);
  290.     STACK_PUSH (gc_prim);
  291.     STACK_PUSH (STACK_FRAME_HEADER + 1);
  292.   Pushed ();
  293.     PRIMITIVE_ABORT (PRIM_APPLY);
  294.   }
  295. }
  296.