mirror of
https://github.com/idris-lang/Idris2.git
synced 2024-12-17 00:10:31 +03:00
a76a1322eb
Written by Volkmar Frinken (@vfrinken). This is intended as a lightweight (i.e. minimal dependencies) code generator that can be ported to multiple platforms, especially those with memory constraints. It shouldn't be expected to be anywhere near as fast as the Scheme back end, for lots of reasons. The main goal is portability.
323 lines
9.1 KiB
C
323 lines
9.1 KiB
C
#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 __unix || __unix__
|
|
return (Value *)makeString("Unix");
|
|
#else
|
|
return (Value *)makeString("Other");
|
|
#endif
|
|
}
|
|
//
|
|
//
|
|
//
|
|
// // -----------------------------------
|
|
// // 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;
|
|
}
|
|
|
|
Value *schemeCall(
|
|
Value *v1, Value *_schemeFuncName, Value *_schemArgs, Value *_world)
|
|
{
|
|
Value_String *schemeFuncName = (Value_String *)_schemeFuncName;
|
|
if (!strcmp("blodwen-thread", schemeFuncName->str))
|
|
{
|
|
fprintf(stderr, "Multithreading not supported\n");
|
|
exit(-1);
|
|
}
|
|
printf("Scheme Call %s not supported\n", schemeFuncName->str);
|
|
|
|
exit(-1);
|
|
}
|
|
|
|
// 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;
|
|
}
|