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 / future.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  12KB  |  387 lines
  1. /* -*-C-*-
  2.  
  3. $Id: future.c,v 9.29 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987, 1988, 1989, 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. /* Support code for futures */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "locks.h"
  27.  
  28. #ifndef COMPILE_FUTURES
  29. #include "Error: future.c is useless without COMPILE_FUTURES"
  30. #endif
  31.  
  32. /* This is how we support future numbering for external metering */
  33. #ifndef New_Future_Number
  34. #define New_Future_Number() SHARP_F
  35. #else
  36. SCHEME_OBJECT Get_New_Future_Number ();
  37. #endif
  38.  
  39. /*
  40.  
  41. A future is a VECTOR starting with <determined?>, <locked?> and
  42. <waiting queue / value>,
  43.  
  44. where <determined?> is #!false if no value is known yet,
  45.                        #!true if value is known and future can vanish at GC,
  46.                        otherwise value is known, but keep the slot
  47.  
  48. and where <locked> is #!true if someone wants slot kept for a time.
  49.  
  50. */
  51.  
  52. DEFINE_PRIMITIVE ("TOUCH", Prim_touch, 1, 1, 0)
  53. {
  54.   SCHEME_OBJECT result;
  55.   PRIMITIVE_HEADER (1);
  56.   TOUCH_IN_PRIMITIVE ((ARG_REF (1)), result);
  57.   PRIMITIVE_RETURN (result);
  58. }
  59.  
  60. DEFINE_PRIMITIVE ("FUTURE?", Prim_future_p, 1, 1, 0)
  61. {
  62.   PRIMITIVE_HEADER (1);
  63.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (FUTURE_P (ARG_REF (1))));
  64. }
  65.  
  66. /* Utility setting routine for use by the various test and set if
  67.    equal operators.
  68. */
  69.  
  70. long
  71. Set_If_Equal(Base, Offset, New, Wanted)
  72.      SCHEME_OBJECT Base, Wanted, New;
  73.      long Offset;
  74. {
  75.   Lock_Handle lock;
  76.   SCHEME_OBJECT Old_Value, Desired, Remember_Value;
  77.   long success;
  78.  
  79.   TOUCH_IN_PRIMITIVE(Wanted, Desired);
  80. Try_Again:
  81.   Remember_Value = MEMORY_REF (Base, Offset);
  82.   TOUCH_IN_PRIMITIVE(Remember_Value, Old_Value);
  83.   lock = Lock_Cell(MEMORY_LOC (Base, Offset));
  84.   if (Remember_Value != FAST_MEMORY_REF (Base, Offset))
  85.   {
  86.     Unlock_Cell(lock);
  87.     goto Try_Again;
  88.   }
  89.   if (Old_Value == Desired)
  90.   {
  91.     Do_Store_No_Lock(MEMORY_LOC (Base, Offset), New);
  92.     success = true;
  93.   }
  94.   else
  95.   {
  96.     success = false;
  97.   }
  98.   Unlock_Cell(lock);
  99.   return success;
  100. }
  101.  
  102. DEFINE_PRIMITIVE ("SET-CAR-IF-EQ?!", Prim_set_car_if_eq, 3, 3,
  103.   "Replace the car of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\
  104. Return PAIR if so, otherwise return '().")
  105. {
  106.   PRIMITIVE_HEADER (3);
  107.   CHECK_ARG (1, PAIR_P);
  108.   {
  109.     fast SCHEME_OBJECT pair = (ARG_REF (1));
  110.     if (Set_If_Equal (pair, CONS_CAR, (ARG_REF (2)), (ARG_REF (3))))
  111.       PRIMITIVE_RETURN (pair);
  112.   }
  113.   PRIMITIVE_RETURN (EMPTY_LIST);
  114. }
  115.  
  116. DEFINE_PRIMITIVE ("SET-CDR-IF-EQ?!", Prim_set_cdr_if_eq, 3, 3,
  117.   "Replace the cdr of PAIR with NEW-VALUE iff it contains OLD-VALUE.\n\
  118. Return PAIR if so, otherwise return '().")
  119. {
  120.   PRIMITIVE_HEADER (3);
  121.   CHECK_ARG (1, PAIR_P);
  122.   {
  123.     fast SCHEME_OBJECT pair = (ARG_REF (1));
  124.     if (Set_If_Equal (pair, CONS_CDR, (ARG_REF (2)), (ARG_REF (3))))
  125.       PRIMITIVE_RETURN (pair);
  126.   }
  127.   PRIMITIVE_RETURN (EMPTY_LIST);
  128. }
  129.  
  130. /* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
  131.    Replaces the <Offset>th element of <Vector> with <New Value> if it used
  132.    to contain <Old Value>.  The value returned is either <Vector> (if
  133.    the modification takes place) or '() if it does not.
  134. */
  135. DEFINE_PRIMITIVE ("VECTOR-SET-IF-EQ?!", Prim_vector_set_if_eq, 4, 4,
  136.   "Replace VECTOR's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\
  137. Return VECTOR if so, otherwise return '().")
  138. {
  139.   PRIMITIVE_HEADER (4);
  140.   CHECK_ARG (1, VECTOR_P);
  141.   {
  142.     fast SCHEME_OBJECT vector = (ARG_REF (1));
  143.     if (Set_If_Equal
  144.     (vector,
  145.      ((arg_index_integer (2, (VECTOR_LENGTH (vector)))) + 1),
  146.      (ARG_REF (3)),
  147.      (ARG_REF (4))))
  148.       PRIMITIVE_RETURN (vector);
  149.   }
  150.   PRIMITIVE_RETURN (EMPTY_LIST);
  151. }
  152.  
  153. DEFINE_PRIMITIVE ("SET-CXR-IF-EQ?!", Prim_set_cxr_if_eq, 4, 4,
  154.   "Replace HUNK3's INDEX'th element with NEW-VALUE iff it contains OLD-VALUE.\n\
  155. Return HUNK3 if so, otherwise return '().")
  156. {
  157.   PRIMITIVE_HEADER (4);
  158.   CHECK_ARG (1, HUNK3_P);
  159.   {
  160.     fast SCHEME_OBJECT hunk3 = (ARG_REF (1));
  161.     if (Set_If_Equal
  162.     (hunk3,
  163.      ((arg_index_integer (2, 3)) + 1),
  164.      (ARG_REF (3)),
  165.      (ARG_REF (4))))
  166.       PRIMITIVE_RETURN (hunk3);
  167.   }
  168.   PRIMITIVE_RETURN (EMPTY_LIST);
  169. }
  170.  
  171. DEFINE_PRIMITIVE ("FUTURE-SIZE", Prim_future_size, 1, 1,
  172.   "Return the number of elements in FUTURE.\n\
  173. This is similar to SYSTEM-VECTOR-SIZE,\n\
  174. but works only on futures and doesn't touch them.")
  175. {
  176.   PRIMITIVE_HEADER (1)
  177.   CHECK_ARG (1, FUTURE_P);
  178.   PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (VECTOR_LENGTH (ARG_REF (1))));
  179. }
  180.  
  181. DEFINE_PRIMITIVE ("FUTURE-REF", Prim_future_ref, 2, 2,
  182.   "Return FUTURE's INDEX'th element.\n\
  183. This is similar to SYSTEM-VECTOR-REF,\n\
  184. but works only on futures and doesn't touch them.")
  185. {
  186.   PRIMITIVE_HEADER (2);
  187.   CHECK_ARG (1, FUTURE_P);
  188.   {
  189.     fast SCHEME_OBJECT future = (ARG_REF (1));
  190.     PRIMITIVE_RETURN
  191.       (VECTOR_REF
  192.        (future, (arg_index_integer (2, (VECTOR_LENGTH (future))))));
  193.   }
  194. }
  195.  
  196. DEFINE_PRIMITIVE ("FUTURE-SET!", Prim_future_set, 3, 3,
  197.   "Modify FUTURE's INDEX'th element to be VALUE.\n\
  198. This is similar to SYSTEM-VECTOR-SET!,\n\
  199. but works only on futures and doesn't touch them.")
  200. {
  201.   PRIMITIVE_HEADER (3);
  202.   CHECK_ARG (1, FUTURE_P);
  203.   {
  204.     fast SCHEME_OBJECT future = (ARG_REF (1));
  205.     fast long index = (arg_index_integer (2, (VECTOR_LENGTH (future))));
  206.     fast SCHEME_OBJECT result = (VECTOR_REF (future, index));
  207.     VECTOR_SET (future, index, (ARG_REF (3)));
  208.     PRIMITIVE_RETURN (result);
  209.   }
  210. }
  211.  
  212. DEFINE_PRIMITIVE ("LOCK-FUTURE!", Prim_lock_future, 1, 1,
  213.   "Set the lock flag on FUTURE.\n\
  214. This flag prevents FUTURE from being spliced out by the garbage collector.\n\
  215. If FUTURE is not a future, return #F immediately,\n\
  216. otherwise return #T after the lock has been set.\n\
  217. Will wait as long as necessary for the lock to be set.")
  218. {
  219.   PRIMITIVE_HEADER (1);
  220.   {
  221.     fast SCHEME_OBJECT future = (ARG_REF (1));
  222.     if (! (FUTURE_P (future)))
  223.       PRIMITIVE_RETURN (SHARP_F);
  224.     while (1)
  225.       {
  226.     if (INTERRUPT_PENDING_P (INT_Mask))
  227.       signal_interrupt_from_primitive ();
  228.     {
  229.       fast SCHEME_OBJECT lock;
  230.       SWAP_POINTERS ((MEMORY_LOC (future, FUTURE_LOCK)), SHARP_T, lock);
  231.       if (lock == SHARP_F)
  232.         PRIMITIVE_RETURN (SHARP_T);
  233.     }
  234.     Sleep (CONTENTION_DELAY);
  235.       }
  236.   }
  237. }
  238.  
  239. DEFINE_PRIMITIVE ("UNLOCK-FUTURE!", Prim_unlock_future, 1, 1,
  240.   "Clear the lock flag on FUTURE.\n\
  241. If FUTURE is not a future, return #F immediately,\n\
  242. otherwise return #T after the lock has been cleared.")
  243. {
  244.   PRIMITIVE_HEADER (1);
  245.   {
  246.     fast SCHEME_OBJECT future = (ARG_REF (1));
  247.     if (! (FUTURE_P (future)))
  248.       PRIMITIVE_RETURN (SHARP_F);
  249.     if (! (Future_Is_Locked (future)))
  250.       error_wrong_type_arg (1);
  251.     MEMORY_SET (future, FUTURE_LOCK, SHARP_F);
  252.     PRIMITIVE_RETURN (SHARP_T);
  253.   }
  254. }
  255.  
  256. DEFINE_PRIMITIVE ("FUTURE->VECTOR", Prim_future_to_vector, 1, 1,
  257.   "Return a newly-allocated vector containing FUTURE's elements.
  258. If FUTURE is not a future, return #F instead.")
  259. {
  260.   PRIMITIVE_HEADER (1);
  261.   {
  262.     SCHEME_OBJECT future = (ARG_REF (1));
  263.     if (! (FUTURE_P (future)))
  264.       PRIMITIVE_RETURN (SHARP_F);
  265.     {
  266.       long length = (VECTOR_LENGTH (future));
  267.       fast SCHEME_OBJECT * scan_source = (MEMORY_LOC (future, 1));
  268.       fast SCHEME_OBJECT * end_source = (scan_source + length);
  269.       SCHEME_OBJECT result =
  270.     (allocate_marked_vector (TC_VECTOR, length, true));
  271.       fast SCHEME_OBJECT * scan_result = (MEMORY_LOC (result, 1));
  272.       while (scan_source < end_source)
  273.     (*scan_result++) = (MEMORY_FETCH (*scan_source++));
  274.       PRIMITIVE_RETURN (result);
  275.     }
  276.   }
  277. }
  278.  
  279. DEFINE_PRIMITIVE ("NON-TOUCHING-EQ?", Prim_future_eq, 2, 2, 0)
  280. {
  281.   PRIMITIVE_HEADER (2);
  282.   PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((ARG_REF (1)) == (ARG_REF (2))));
  283. }
  284.  
  285. /* MAKE-INITIAL-PROCESS is called to create a small stacklet which
  286.  * will just call the specified thunk and then end the computation
  287.  */
  288.  
  289. DEFINE_PRIMITIVE ("MAKE-INITIAL-PROCESS", Prim_make_initial_process, 1, 1, 0)
  290. {
  291.   SCHEME_OBJECT Result;
  292.   long Useful_Length;
  293.   PRIMITIVE_HEADER (1);
  294.  
  295.   Result = MAKE_POINTER_OBJECT (TC_CONTROL_POINT, Free);
  296.   Useful_Length = (3 * CONTINUATION_SIZE) + STACK_ENV_EXTRA_SLOTS + 1;
  297.  
  298. #ifdef USE_STACKLETS
  299.  
  300.   {
  301.     long Allocated_Length, Waste_Length;
  302.  
  303.     Allocated_Length = (Useful_Length + STACKLET_SLACK + STACKLET_HEADER_SIZE);
  304.     if (Allocated_Length < Default_Stacklet_Size)
  305.     {
  306.       Allocated_Length = Default_Stacklet_Size;
  307.       Waste_Length = ((Allocated_Length + 1) -
  308.               (Useful_Length + STACKLET_HEADER_SIZE));
  309.     }
  310.     else
  311.     {
  312.       Waste_Length = (STACKLET_SLACK + 1);
  313.     }
  314.     Primitive_GC_If_Needed(Allocated_Length + 1);
  315.     Free[STACKLET_LENGTH] =
  316.       MAKE_POINTER_OBJECT (TC_MANIFEST_VECTOR, Allocated_Length);
  317.     Free[STACKLET_REUSE_FLAG] = SHARP_T;
  318.     Free[STACKLET_UNUSED_LENGTH] =
  319.       MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, Waste_Length);
  320.     Free += (Allocated_Length + 1) - Useful_Length;
  321.   }
  322.  
  323. #else /* not USE_STACKLETS */
  324.  
  325.   Free[STACKLET_LENGTH] =
  326.     MAKE_OBJECT (TC_MANIFEST_VECTOR, Useful_Length + STACKLET_HEADER_SIZE - 1);
  327.   Free[STACKLET_REUSE_FLAG] = SHARP_F;
  328.   Free[STACKLET_UNUSED_LENGTH] = MAKE_OBJECT (TC_MANIFEST_NM_VECTOR, 0);
  329.   Free += STACKLET_HEADER_SIZE;
  330.  
  331. #endif /* USE_STACKLETS */
  332.  
  333.   Free[CONTINUATION_EXPRESSION] = LONG_TO_FIXNUM(FETCH_INTERRUPT_MASK());
  334.   Free[CONTINUATION_RETURN_CODE] =
  335.     MAKE_OBJECT (TC_RETURN_CODE, RC_RESTORE_INT_MASK);
  336.   Free += CONTINUATION_SIZE;
  337.   Free[CONTINUATION_EXPRESSION] = SHARP_F;
  338.   Free[CONTINUATION_RETURN_CODE] =
  339.     MAKE_OBJECT (TC_RETURN_CODE, RC_INTERNAL_APPLY);
  340.   Free += CONTINUATION_SIZE;
  341.   *Free++ = STACK_FRAME_HEADER;
  342.   *Free++ = (ARG_REF (1));
  343.   Free[CONTINUATION_EXPRESSION] = (ARG_REF (1)); /* For testing & debugging */
  344.   Free[CONTINUATION_RETURN_CODE] =
  345.     MAKE_OBJECT (TC_RETURN_CODE, RC_END_OF_COMPUTATION);
  346.   Free += CONTINUATION_SIZE;
  347.   PRIMITIVE_RETURN (Result);
  348. }
  349.  
  350. /*
  351.   Absolutely the cheapest future we can make.  This includes
  352.   the I/O stuff and whatnot.  Notice that the name is required.
  353.  
  354.   (make-cheap-future orig-code user-proc name)
  355.  
  356. */
  357.  
  358. DEFINE_PRIMITIVE ("MAKE-CHEAP-FUTURE", Prim_make_cheap_future, 3, 3, 0)
  359. {
  360.   PRIMITIVE_HEADER (3);
  361.   {
  362.     fast SCHEME_OBJECT future = (allocate_marked_vector (TC_FUTURE, 10, true));
  363.     FAST_MEMORY_SET (future, FUTURE_IS_DETERMINED, SHARP_F);
  364.     FAST_MEMORY_SET (future, FUTURE_LOCK, SHARP_F);
  365.     FAST_MEMORY_SET (future, FUTURE_QUEUE, (cons (EMPTY_LIST, EMPTY_LIST)));
  366.     FAST_MEMORY_SET (future, FUTURE_PROCESS, (ARG_REF (1)));
  367.     FAST_MEMORY_SET (future, FUTURE_STATUS, SHARP_T);
  368.     FAST_MEMORY_SET (future, FUTURE_ORIG_CODE, (ARG_REF (2)));
  369.     /* Put the I/O system stuff here. */
  370.     FAST_MEMORY_SET
  371.       (future,
  372.        FUTURE_PRIVATE,
  373.        (make_vector
  374.     (1,
  375.      (hunk3_cons
  376.       (SHARP_F,
  377.        (ARG_REF (3)),
  378.        (cons ((LONG_TO_UNSIGNED_FIXNUM (0)),
  379.           (char_pointer_to_string ("")))))),
  380.      true)));
  381.     FAST_MEMORY_SET (future, FUTURE_WAITING_ON, EMPTY_LIST);
  382.     FAST_MEMORY_SET (future, FUTURE_METERING, (New_Future_Number ()));
  383.     FAST_MEMORY_SET (future, FUTURE_USER, SHARP_F);
  384.     PRIMITIVE_RETURN (future);
  385.   }
  386. }
  387.