Idris2/support/refc/prim.c

#include "prim.h"
#include "refc_util.h"
#include <string.h>
#include <unistd.h>

// This is NOT THREAD SAFE in the current implementation

IORef_Storage *newIORef_Storage(int capacity) {
  IORef_Storage *retVal = (IORef_Storage *)malloc(sizeof(IORef_Storage));
  IDRIS2_REFC_VERIFY(retVal, "malloc failed");
  retVal->filled = 0;
  retVal->total = capacity;
  retVal->refs = (Value **)malloc(sizeof(Value *) * retVal->total);
  return retVal;
}

void doubleIORef_Storage(IORef_Storage *ior) {
  Value **values = (Value **)malloc(sizeof(Value *) * ior->total * 2);
  IDRIS2_REFC_VERIFY(values, "malloc failed");
  ior->total *= 2;
  for (int i = 0; i < ior->filled; i++) {
    values[i] = ior->refs[i];
  }
  free(ior->refs);
  ior->refs = values;
}

Value *newIORef(Value *erased, Value *input_value, Value *_world) {
  // if no ioRef Storag exist, start with one
  if (!global_IORef_Storage) {
    global_IORef_Storage = newIORef_Storage(128);
  }
  // expand size of needed
  if (global_IORef_Storage->filled >= global_IORef_Storage->total) {
    doubleIORef_Storage(global_IORef_Storage);
  }

  // store value
  Value_IORef *ioRef = IDRIS2_NEW_VALUE(Value_IORef);
  ioRef->header.tag = IOREF_TAG;
  ioRef->index = global_IORef_Storage->filled;
  global_IORef_Storage->refs[global_IORef_Storage->filled] =
      newReference(input_value);
  global_IORef_Storage->filled++;

  return (Value *)ioRef;
}

Value *readIORef(Value *erased, Value *_index, Value *_world) {
  Value_IORef *index = (Value_IORef *)_index;
  return newReference(global_IORef_Storage->refs[index->index]);
}

Value *writeIORef(Value *erased, Value *_index, Value *new_value,
                  Value *_world) {
  Value_IORef *index = (Value_IORef *)_index;
  removeReference(global_IORef_Storage->refs[index->index]);
  global_IORef_Storage->refs[index->index] = newReference(new_value);
  return newReference(_index);
}

// -----------------------------------
//       System operations
// -----------------------------------

Value *sysOS(void) {
#ifdef _WIN32
  return (Value *)makeString("windows");
#elif _WIN64
  return (Value *)makeString("windows");
#elif __APPLE__ || __MACH__
  return (Value *)makeString("macOS");
#elif __linux__
  return (Value *)makeString("Linux");
#elif __FreeBSD__
  return (Value *)makeString("FreeBSD");
#elif __OpenBSD__
  return (Value *)makeString("OpenBSD");
#elif __NetBSD__
  return (Value *)makeString("NetBSD");
#elif __DragonFly__
  return (Value *)makeString("DragonFly");
#elif __unix || __unix__
  return (Value *)makeString("Unix");
#else
  return (Value *)makeString("Other");
#endif
}

Value *idris2_crash(Value *msg) {
  Value_String *str = (Value_String *)msg;
  printf("ERROR: %s\n", str->str);
  exit(-1);
}

//
//
//
// // -----------------------------------
// //         Array operations
// // -----------------------------------

Value *newArray(Value *erased, Value *_length, Value *v, Value *_word) {
  int length = extractInt(_length);
  Value_Array *a = makeArray(length);

  for (int i = 0; i < length; i++) {
    a->arr[i] = newReference(v);
  }

  return (Value *)a;
}

Value *arrayGet(Value *erased, Value *_array, Value *_index, Value *_word) {
  Value_Array *a = (Value_Array *)_array;
  return newReference(a->arr[((Value_Int64 *)_index)->i64]);
}

Value *arraySet(Value *erased, Value *_array, Value *_index, Value *v,
                Value *_word) {
  Value_Array *a = (Value_Array *)_array;
  removeReference(a->arr[((Value_Int64 *)_index)->i64]);
  a->arr[((Value_Int64 *)_index)->i64] = newReference(v);
  return NULL;
}

//
// -----------------------------------
//      Pointer operations
// -----------------------------------

Value *onCollect(Value *_erased, Value *_anyPtr, Value *_freeingFunction,
                 Value *_world) {
  Value_GCPointer *retVal = IDRIS2_NEW_VALUE(Value_GCPointer);
  retVal->header.tag = GC_POINTER_TAG;
  retVal->p = (Value_Pointer *)newReference(_anyPtr);
  retVal->onCollectFct = (Value_Closure *)newReference(_freeingFunction);
  return (Value *)retVal;
}

Value *onCollectAny(Value *_anyPtr, Value *_freeingFunction, Value *_world) {
  Value_GCPointer *retVal = IDRIS2_NEW_VALUE(Value_GCPointer);
  retVal->header.tag = GC_POINTER_TAG;
  retVal->p = (Value_Pointer *)newReference(_anyPtr);
  retVal->onCollectFct = (Value_Closure *)newReference(_freeingFunction);
  return (Value *)retVal;
}

Value *voidElim(Value *erased1, Value *erased2) { return NULL; }

// Threads

// %foreign "scheme:blodwen-mutex"
// prim__makeMutex : PrimIO Mutex
// using pthread_mutex_init(pthread_mutex_t *mutex, const pthread_mutexattr_t
// *attr)
Value *System_Concurrency_Raw_prim__makeMutex(Value *_world) {
  Value_Mutex *mut = IDRIS2_NEW_VALUE(Value_Mutex);
  mut->header.tag = MUTEX_TAG;
  mut->mutex = (pthread_mutex_t *)malloc(sizeof(pthread_mutex_t));
  int r = pthread_mutex_init(mut->mutex, NULL);
  IDRIS2_REFC_VERIFY(!r, "pthread_mutex_init failed: %s", strerror(r));
  return (Value *)mut;
}

// %foreign "scheme:blodwen-lock"
// prim__mutexAcquire : Mutex -> PrimIO ()
// using pthread_mutex_lock(pthread_mutex_t *mutex)
Value *System_Concurrency_Raw_prim__mutexAcquire(Value *_mutex, Value *_world) {
  int r = pthread_mutex_lock(((Value_Mutex *)_mutex)->mutex);
  IDRIS2_REFC_VERIFY(!r, "pthread_mutex_lock failed: %s", strerror(r));
  return NULL;
}

// %foreign "scheme:blodwen-unlock"
// prim__mutexRelease : Mutex -> PrimIO ()
// using int pthread_mutex_unlock(pthread_mutex_t *mutex)
Value *System_Concurrency_Raw_prim__mutexRelease(Value *_mutex, Value *_world) {
  int r = pthread_mutex_unlock(((Value_Mutex *)_mutex)->mutex);
  IDRIS2_REFC_VERIFY(!r, "pthread_mutex_unlock failed: %s", strerror(r));
  return NULL;
}

// %foreign "scheme:blodwen-condition"
// prim__makeCondition : PrimIO Condition
// using int pthread_cond_init(pthread_cond_t *cond, const pthread_condattr_t
// *attr) with standard initialisation
Value *System_Concurrency_Raw_prim__makeCondition(Value *_world) {
  // typedef struct{
  //     Value_header header;
  //     pthread_cond_t *cond;
  // }Value_Condition;

  Value_Condition *c = IDRIS2_NEW_VALUE(Value_Condition);
  c->header.tag = CONDITION_TAG;
  c->cond = (pthread_cond_t *)malloc(sizeof(pthread_cond_t));
  IDRIS2_REFC_VERIFY(c->cond, "malloc failed");
  int r = pthread_cond_init(c->cond, NULL);
  IDRIS2_REFC_VERIFY(!r, "pthread_cond_init failed: %s", strerror(r));
  return (Value *)c;
}

// %foreign "scheme:blodwen-condition-wait"
// prim__conditionWait : Condition -> Mutex -> PrimIO ()
// using int pthread_cond_wait(pthread_cond_t *, pthread_mutex_t *mutex)
Value *System_Concurrency_Raw_prim__conditionWait(Value *_condition,
                                                  Value *_mutex,
                                                  Value *_world) {
  Value_Condition *cond = (Value_Condition *)_condition;
  Value_Mutex *mutex = (Value_Mutex *)_mutex;
  int r = pthread_cond_wait(cond->cond, mutex->mutex);
  IDRIS2_REFC_VERIFY(!r, "pthread_cond_wait failed: %s", strerror(r));
  return NULL;
}

// %foreign "scheme:blodwen-condition-wait-timeout"
// prim__conditionWaitTimeout : Condition -> Mutex -> Int -> PrimIO ()
// using int pthread_cond_timedwait(pthread_cond_t *cond, pthread_mutex_t
// *mutex, const struct timespec *abstime)
Value *System_Concurrency_Raw_prim__conditionWaitTimeout(Value *_condition,
                                                         Value *_mutex,
                                                         Value *_timeout,
                                                         Value *_world) {
  Value_Condition *cond = (Value_Condition *)_condition;
  Value_Mutex *mutex = (Value_Mutex *)_mutex;
  Value_Int64 *timeout = (Value_Int64 *)_timeout;
  struct timespec t;
  t.tv_sec = timeout->i64 / 1000000;
  t.tv_nsec = timeout->i64 % 1000000;
  int r = pthread_cond_timedwait(cond->cond, mutex->mutex, &t);
  IDRIS2_REFC_VERIFY(!r, "pthread_cond_timedwait failed: %s", strerror(r));
  return NULL;
}

// %foreign "scheme:blodwen-condition-signal"
// prim__conditionSignal : Condition -> PrimIO ()
// using int pthread_cond_signal(pthread_cond_t *cond)
Value *System_Concurrency_Raw_prim__conditionSignal(Value *_condition,
                                                    Value *_world) {
  Value_Condition *cond = (Value_Condition *)_condition;
  int r = pthread_cond_signal(cond->cond);
  IDRIS2_REFC_VERIFY(!r, "pthread_cond_signal failed: %s", strerror(r));
  return NULL;
}

// %foreign "scheme:blodwen-condition-broadcast"
// prim__conditionBroadcast : Condition -> PrimIO ()
// using int pthread_cond_broadcast(pthread_cond_t *cond)
Value *System_Concurrency_Raw_prim__conditionBroadcast(Value *_condition,
                                                       Value *_mutex) {
  Value_Condition *cond = (Value_Condition *)_condition;
  int r = pthread_cond_broadcast(cond->cond);
  IDRIS2_REFC_VERIFY(!r, "pthread_cond_broadcast failed: %s", strerror(r));
  return NULL;
}