mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-01 09:49:24 +03:00
324 lines
9.1 KiB
C
324 lines
9.1 KiB
C
#include <unistd.h>
|
|
#include "prim.h"
|
|
|
|
Value *Prelude_IO_prim__getChar(Value *world)
|
|
{
|
|
char c = getchar();
|
|
return (Value *)makeChar(c);
|
|
}
|
|
|
|
// This is NOT THREAD SAFE in the current implementation
|
|
|
|
IORef_Storage *newIORef_Storage(int capacity)
|
|
{
|
|
IORef_Storage *retVal = (IORef_Storage *)malloc(sizeof(IORef_Storage));
|
|
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);
|
|
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
|
|
Value_World *world = (Value_World *)_world;
|
|
if (!world->listIORefs)
|
|
{
|
|
world->listIORefs = newIORef_Storage(128);
|
|
}
|
|
// expand size of needed
|
|
if (world->listIORefs->filled >= world->listIORefs->total)
|
|
{
|
|
doubleIORef_Storage(world->listIORefs);
|
|
}
|
|
|
|
// store value
|
|
Value_IORef *ioRef = (Value_IORef *)newValue();
|
|
ioRef->header.tag = IOREF_TAG;
|
|
ioRef->index = world->listIORefs->filled;
|
|
world->listIORefs->refs[world->listIORefs->filled] = newReference(input_value);
|
|
world->listIORefs->filled++;
|
|
|
|
return (Value *)ioRef;
|
|
}
|
|
|
|
Value *readIORef(Value *erased, Value *_index, Value *_world)
|
|
{
|
|
Value_World *world = (Value_World *)_world;
|
|
Value_IORef *index = (Value_IORef *)_index;
|
|
return newReference(world->listIORefs->refs[index->index]);
|
|
}
|
|
|
|
Value *writeIORef(Value *erased, Value *_index, Value *new_value, Value *_world)
|
|
{
|
|
Value_World *world = (Value_World *)_world;
|
|
Value_IORef *index = (Value_IORef *)_index;
|
|
removeReference(world->listIORefs->refs[index->index]);
|
|
world->listIORefs->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("Mac OSX");
|
|
#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_Int32 *)_index)->i32]);
|
|
}
|
|
|
|
Value *arraySet(Value *erased, Value *_array, Value *_index, Value *v, Value *_word)
|
|
{
|
|
Value_Array *a = (Value_Array *)_array;
|
|
removeReference(a->arr[((Value_Int32 *)_index)->i32]);
|
|
a->arr[((Value_Int32 *)_index)->i32] = newReference(v);
|
|
return NULL;
|
|
}
|
|
|
|
//
|
|
// -----------------------------------
|
|
// Pointer operations
|
|
// -----------------------------------
|
|
|
|
Value *PrimIO_prim__nullAnyPtr(Value *ptr)
|
|
{
|
|
void *p;
|
|
switch (ptr->header.tag)
|
|
{
|
|
case STRING_TAG:
|
|
p = ((Value_String *)ptr)->str;
|
|
break;
|
|
case POINTER_TAG:
|
|
p = ((Value_Pointer *)ptr)->p;
|
|
break;
|
|
default:
|
|
p = NULL;
|
|
}
|
|
if (p)
|
|
{
|
|
return (Value *)makeInt32(0);
|
|
}
|
|
else
|
|
{
|
|
return (Value *)makeInt32(1);
|
|
}
|
|
}
|
|
|
|
Value *onCollect(Value *_erased, Value *_anyPtr, Value *_freeingFunction, Value *_world)
|
|
{
|
|
printf("onCollect called\n");
|
|
Value_GCPointer *retVal = (Value_GCPointer *)newValue();
|
|
retVal->header.tag = GC_POINTER_TAG;
|
|
retVal->p = (Value_Pointer *)newReference(_anyPtr);
|
|
retVal->onCollectFct = (Value_Closure *)newReference(_freeingFunction);
|
|
return (Value *)retVal;
|
|
}
|
|
|
|
Value *onCollectAny(Value *_erased, Value *_anyPtr, Value *_freeingFunction, Value *_world)
|
|
{
|
|
printf("onCollectAny called\n");
|
|
Value_GCPointer *retVal = (Value_GCPointer *)newValue();
|
|
retVal->header.tag = GC_POINTER_TAG;
|
|
retVal->p = (Value_Pointer *)_anyPtr;
|
|
retVal->onCollectFct = (Value_Closure *)_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 = (Value_Mutex *)newValue();
|
|
mut->header.tag = MUTEX_TAG;
|
|
mut->mutex = (pthread_mutex_t *)malloc(sizeof(pthread_mutex_t));
|
|
if (pthread_mutex_init(mut->mutex, NULL))
|
|
{
|
|
fprintf(stderr, "Error init Mutex\n");
|
|
exit(-1);
|
|
}
|
|
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)
|
|
{
|
|
if (pthread_mutex_lock(((Value_Mutex *)_mutex)->mutex))
|
|
{
|
|
fprintf(stderr, "Error locking mutex\n");
|
|
exit(-1);
|
|
}
|
|
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)
|
|
{
|
|
if (pthread_mutex_unlock(((Value_Mutex *)_mutex)->mutex))
|
|
{
|
|
fprintf(stderr, "Error locking mutex\n");
|
|
exit(-1);
|
|
}
|
|
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 = (Value_Condition *)newValue();
|
|
c->header.tag = CONDITION_TAG;
|
|
c->cond = (pthread_cond_t *)malloc(sizeof(pthread_cond_t));
|
|
if (pthread_cond_init(c->cond, NULL))
|
|
{
|
|
fprintf(stderr, "error init condition\n");
|
|
exit(-1);
|
|
}
|
|
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;
|
|
if (pthread_cond_wait(cond->cond, mutex->mutex))
|
|
{
|
|
fprintf(stderr, "Error Conditional Wait\n");
|
|
exit(-1);
|
|
}
|
|
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_Int32 *timeout = (Value_Int32 *)_timeout;
|
|
struct timespec t;
|
|
t.tv_sec = timeout->i32 / 1000000;
|
|
t.tv_nsec = timeout->i32 % 1000000;
|
|
if (pthread_cond_timedwait(cond->cond, mutex->mutex, &t))
|
|
{
|
|
fprintf(stderr, "Error in pthread_cond_timedwait\n");
|
|
exit(-1);
|
|
}
|
|
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;
|
|
if (pthread_cond_signal(cond->cond))
|
|
{
|
|
fprintf(stderr, "Error in pthread_cond_signal\n");
|
|
exit(-1);
|
|
}
|
|
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;
|
|
if (pthread_cond_broadcast(cond->cond))
|
|
{
|
|
fprintf(stderr, "Error in pthread_cond_broadcast\n");
|
|
exit(-1);
|
|
}
|
|
return NULL;
|
|
}
|