⟦0eba1e28f⟧

TextFile

/*          Hey EMACS, this is -*- C -*- code!                 */

/****************************************************************
*                                                               *
*                         Copyright (c) 1985                    *
*               Massachusetts Institute of Technology           *
*                                                               *
* This material was developed by the Scheme project at the      *
* Massachusetts Institute of Technology, Department of          *
* Electrical Engineering and Computer Science.  Permission to   *
* copy this software, to redistribute it, and to use it for any *
* purpose is granted, subject to the following restrictions and *
* understandings.                                               *
*                                                               *
* 1. Any copy made of this software must include this copyright *
* notice in full.                                               *
*                                                               *
* 2. Users of this software agree to make their best efforts (a)*
* to return to the MIT Scheme project any improvements or       *
* extensions that they make, so that these may be included in   *
* future releases; and (b) to inform MIT of noteworthy uses of  *
* this software.                                                *
*                                                               *
* 3.  All materials developed as a consequence of the use of    *
* this software shall duly acknowledge such use, in accordance  *
* with the usual standards of acknowledging credit in academic  *
* research.                                                     *
*                                                               *
* 4. MIT has made no warrantee or representation that the       *
* operation of this software will be error-free, and MIT is     *
* under no obligation to provide any services, by way of        *
* maintenance, update, or otherwise.                            *
*                                                               *
* 5.  In conjunction with products arising from the use of this *
* material, there shall be no use of the name of the            *
* Massachusetts Institute of Technology nor of any adaptation   *
* thereof in any advertising, promotional, or sales literature  *
* without prior written consent from MIT in each case.          *
*                                                               *
****************************************************************/

/* File: FUTURE.C
   Support code for futures
*/

#include "scheme.h"
#include "primitive.h"
#include "locks.h"
\f


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

/* (future <e> #!Optional Scheduler) =>

(let ((object (make-future)))
  (catch (lambda (X)
	   (halt
	    (determine object
		       (<scheduler> (lambda () (X object))
				    (lambda () <e>)))))))

(define (make-future)
  (primitive-set-type ... #(#!false '() ...)))

A future is a VECTOR starting with <determined?>, <locked?> and 
<waiting queue / value>,

where <determined?> is #!false if no value is known yet,
                       #!true if value is known and future can vanish at GC,
                       otherwise value is known, but keep the slot

and where <locked> is #!true if someone wants slot kept for a time.

We may have to keep the closure around in case we want delay-like operation.

*/
\f


Define_Primitive(Prim_Touch, 1, "TOUCH")
{ Pointer Result;
  Primitive_1_Arg();
  Touch_In_Primitive(Arg1, Result);
  return Result;
}

Define_Primitive(Prim_Future_P, 1, "FUTURE?")
{ Primitive_1_Arg();
  return (Type_Code(Arg1) == TC_FUTURE) ? TRUTH : NIL;
}
\f


/* Utility setting routine for use by the various test and set if
   equal operators.
*/

long Set_If_Equal(Base, Offset, New, Wanted)
Pointer Base, Wanted, New;
long Offset;
{ Lock_Handle lock;
  Pointer Old_Value, Desired, Remember_Value;
  long success;

  Touch_In_Primitive(Wanted, Desired);
Try_Again:
  Remember_Value = Vector_Ref(Base, Offset);
  Touch_In_Primitive(Remember_Value, Old_Value);
  lock = Lock_Cell(Nth_Vector_Loc(Base, Offset));
  if (Remember_Value != Fast_Vector_Ref(Base, Offset))
  { Unlock_Cell(lock);
    goto Try_Again;
  }
  if (Old_Value == Desired)
  { Do_Store_No_Lock(Nth_Vector_Loc(Base, Offset), New);
    success = true;
  }
  else success = false;
  Unlock_Cell(lock);
  return success;
}

Define_Primitive(Prim_Set_Car_If_Eq, 3, "SET-CAR-IF-EQ?!")
/* (SET-CAR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
   Replaces the CAR of <CONS Cell> with <New Value> if it used to contain
   <Old Value>.  The value returned is either <CONS Cell> (if the modification
   takes place) or '() if it does not.
*/
{ Primitive_3_Args();
  Arg_1_Type(TC_LIST);
  if (Set_If_Equal(Arg1, CONS_CAR, Arg2, Arg3)) return Arg1;
  else return NIL;
}
\f

  
Define_Primitive(Prim_Set_Cdr_If_Eq, 3, "SET-CDR-IF-EQ?!")
/* (SET-CDR-IF-EQ?! <CONS Cell> <New Value> <Old Value>)
   Replaces the CDR of <CONS Cell> with <New Value> if it used to contain
   <Old Value>.  The value returned is either <CONS Cell> (if the modification
   takes place) or '() if it does not.
*/
{ Primitive_3_Args();
  Arg_1_Type(TC_LIST);
  if (Set_If_Equal(Arg1, CONS_CDR, Arg2, Arg3)) return Arg1;
  else return NIL;
}

Define_Primitive(Prim_Vector_Set_If_Eq, 4, "VECTOR-SET-IF-EQ?!")
/* (VECTOR-SET-IF-EQ?! <Vector> <Offset> <New Value> <Old Value>)
   Replaces the <Offset>th element of <Vector> with <New Value> if it used
   to contain <Old Value>.  The value returned is either <Vector> (if
   the modification takes place) or '() if it does not.
*/
{ Pointer Arg4;
  long Offset;
  Primitive_3_Args();
  Arg4 = Stack_Pointer[3];
  Arg_1_Type(TC_VECTOR);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2,
              0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
  if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1;
  else return NIL;
}

Define_Primitive(Prim_Set_Cxr_If_Eq, 4, "SET-CXR-IF-EQ?!")
/* (SET-CXR-IF-EQ?! <Triple> <Offset> <New Value> <Old Value>)
   Replaces the <Offset>th CXR of <Triple> with <New Value> if it used to
   contain <Old Value>.  The value returned is either <Triple> (if
   the modification takes place) or '() if it does not.
*/
{ Pointer Arg4;
  long Offset;
  Primitive_3_Args();
  Arg4 = Stack_Pointer[3];
  Arg_1_Type(TC_HUNK3);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2, 0, 2, ERR_ARG_2_BAD_RANGE);
  if (Set_If_Equal(Arg1, Offset, Arg3, Arg4)) return Arg1;
  else return NIL;
}
\f


Define_Primitive(Prim_Future_Ref, 2, "FUTURE-REF")
/* (FUTURE-REF <Future> <Offset>)
   Returns the <Offset>th slot from the future object.  This is
   the equivalent of SYSTEM-VECTOR-REF but works only on future
   objects and doesn't touch.
*/
{ long Offset;
  Primitive_2_Args();
  Arg_1_Type(TC_FUTURE);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2,
              0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
  return User_Vector_Ref(Arg1, Offset);
}

Define_Primitive(Prim_Future_Set, 3, "FUTURE-SET!")
/* (FUTURE-SET! <Future> <Offset> <New Value>)
   Modifies the <Offset>th slot from the future object.  This is
   the equivalent of SYSTEM-VECTOR-SET! but works only on future
   objects and doesn't touch.
*/
{ long Offset;
  Pointer Result;
  Primitive_3_Args();
  Arg_1_Type(TC_FUTURE);
  Arg_2_Type(TC_FIXNUM);
  Range_Check(Offset, Arg2,
              0, Vector_Length(Arg1)-1, ERR_ARG_2_BAD_RANGE);
  Result = User_Vector_Ref(Arg1, Offset);
  User_Vector_Set(Arg1, Offset,Arg3);
  return Result;
}
\f


Define_Primitive(Prim_Future_Size, 1, "FUTURE-SIZE")
/* (FUTURE-SIZE <Future>)
   Returns the number of slots in the future object.  This is
   the equivalent of SYSTEM-VECTOR-SIZE but works only on future
   objects and doesn't touch.
*/
{ Primitive_1_Arg();
  Arg_1_Type(TC_FUTURE);
  return FIXNUM_0+Vector_Length(Arg1);
}

Define_Primitive(Prim_Lock_Future, 1, "LOCK-FUTURE!")
/* (LOCK-FUTURE! <Future>)
   Sets the lock flag on the future object, so that it won't be 
   spliced-out by the garbage collector. Returns #!false if the
   argument isn't a future (might have been determined in the
   interim), #!TRUE if it is a future.  Hangs as long as necessary
   for the lock to take, since Scheme code operates while locked.
   Opposite of UNLOCK-FUTURE!.
*/
{ Primitive_1_Arg();
  if (Type_Code(Arg1) != TC_FUTURE) return NIL;
  while ((IntEnb & IntCode) == 0)
    if (Swap_Pointers(Nth_Vector_Loc(Arg1, FUTURE_LOCK), 
                      TRUTH) == NIL)
       return TRUTH;
    else Sleep(CONTENTION_DELAY);
  Primitive_Interrupt();
}

Define_Primitive(Prim_Unlock_Future, 1, "UNLOCK-FUTURE!")
/* (UNLOCK-FUTURE! <Future>)
   Clears the lock flag on a locked future object, otherwise nothing.
*/
{ Primitive_1_Arg();
  if (Type_Code(Arg1) != TC_FUTURE) return NIL;
  if (!Future_Is_Locked(Arg1))
    Primitive_Error(ERR_ARG_1_WRONG_TYPE)
  else
  { Vector_Set(Arg1, FUTURE_LOCK, NIL);
    return TRUTH;
  };
}
\f


/* Timer handling is mostly in the files included by os.c */

Define_Primitive(Prim_Setup_Timer_Interrupt, 2, "SETUP-TIMER-INTERRUPT")
{ Primitive_2_Args();
  if ((Arg1==NIL) && (Arg2==NIL)) Clear_Timer();
  else
  { long Days, Centi_Seconds;
    Arg_1_Type(TC_FIXNUM);
    Arg_2_Type(TC_FIXNUM);
    Sign_Extend(Arg1, Days);
    Sign_Extend(Arg2, Centi_Seconds);
    Set_Timer(Days, Centi_Seconds);
  }
  IntCode &= ~INT_Timer;
  return NIL;
}
DataMuseum.dk

DKUUG/EUUG Conference tapes

⟦0eba1e28f⟧ TextFile

Derivation

TextFile
