#ifndef _IDRISRTS_H #define _IDRISRTS_H #include #include #include #include #ifdef HAS_PTHREAD #include #endif #include #include #include "idris_heap.h" #include "idris_stats.h" #ifndef EXIT_SUCCESS #define EXIT_SUCCESS 0 #endif #ifndef EXIT_FAILURE #define EXIT_FAILURE 1 #endif // Closures typedef enum { CON, INT, BIGINT, FLOAT, STRING, STROFFSET, BITS8, BITS16, BITS32, BITS64, UNIT, PTR, FWD, MANAGEDPTR, BUFFER, BITS8X16, BITS16X8, BITS32X4, BITS64X2 } ClosureType; typedef struct Closure *VAL; typedef struct { uint32_t tag_arity; VAL args[]; } con; typedef struct { VAL str; size_t offset; } StrOffset; typedef struct { // If we ever have multithreaded access to the same heap, // fill is mutable so needs synchronization! size_t fill; size_t cap; unsigned char store[]; } Buffer; // A foreign pointer, managed by the idris GC typedef struct { size_t size; void* data; } ManagedPtr; typedef struct Closure { // Use top 16 bits of ty for saying which heap value is in // Bottom 16 bits for closure type // // NOTE: ty can not have type ClosureType because ty must be a // uint32_t but enum is platform dependent uint32_t ty; union { con c; int i; double f; char* str; StrOffset* str_offset; void* ptr; uint8_t bits8; uint16_t bits16; uint32_t bits32; uint64_t bits64; __m128i* bits128p; Buffer* buf; ManagedPtr* mptr; } info; } Closure; struct VM_t; struct Msg_t { struct VM_t* sender; VAL msg; }; typedef struct Msg_t Msg; struct VM_t { VAL* valstack; VAL* valstack_top; VAL* valstack_base; VAL* stack_max; Heap heap; #ifdef HAS_PTHREAD pthread_mutex_t inbox_lock; pthread_mutex_t inbox_block; pthread_mutex_t alloc_lock; pthread_cond_t inbox_waiting; Msg* inbox; // Block of memory for storing messages Msg* inbox_end; // End of block of memory Msg* inbox_write; // Location of next message to write int processes; // Number of child processes int max_threads; // maximum number of threads to run in parallel #endif Stats stats; VAL ret; VAL reg1; }; typedef struct VM_t VM; // Create a new VM VM* init_vm(int stack_size, size_t heap_size, int max_threads); // Initialise thread-local data for this VM void init_threaddata(VM *vm); // Clean up a VM once it's no longer needed Stats terminate(VM* vm); // Create a new VM, set up everything with sensible defaults (use when // calling Idris from C) VM* idris_vm(); void close_vm(VM* vm); // Set up key for thread-local data - called once from idris_main void init_threadkeys(); // Functions all take a pointer to their VM, and previous stack base, // and return nothing. typedef void(*func)(VM*, VAL*); // Register access #define RVAL (vm->ret) #define LOC(x) (*(vm->valstack_base + (x))) #define TOP(x) (*(vm->valstack_top + (x))) #define REG1 (vm->reg1) // align pointer #define ALIGN(__p, __alignment) ((__p + __alignment - 1) & ~(__alignment - 1)) // Retrieving values #define GETSTR(x) (ISSTR(x) ? (((VAL)(x))->info.str) : GETSTROFF(x)) #define GETPTR(x) (((VAL)(x))->info.ptr) #define GETMPTR(x) (((VAL)(x))->info.mptr->data) #define GETFLOAT(x) (((VAL)(x))->info.f) #define TAG(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity >> 8 : (-1)) ) #define ARITY(x) (ISINT(x) || x == NULL ? (-1) : ( GETTY(x) == CON ? (x)->info.c.tag_arity & 0x000000ff : (-1)) ) // Already checked it's a CON #define CTAG(x) (((x)->info.c.tag_arity) >> 8) #define CARITY(x) ((x)->info.c.tag_arity & 0x000000ff) // Use top 16 bits for saying which heap value is in // Bottom 16 bits for closure type #define GETTY(x) ((x)->ty & 0x0000ffff) #define SETTY(x,t) (x)->ty = (((x)->ty & 0xffff0000) | (t)) #define GETHEAP(x) ((x)->ty >> 16) #define SETHEAP(x,y) (x)->ty = (((x)->ty & 0x0000ffff) | ((y) << 16)) // Integers, floats and operators typedef intptr_t i_int; #define MKINT(x) ((void*)((x)<<1)+1) #define GETINT(x) ((i_int)(x)>>1) #define ISINT(x) ((((i_int)x)&1) == 1) #define ISSTR(x) (GETTY(x) == STRING) #define INTOP(op,x,y) MKINT((i_int)((((i_int)x)>>1) op (((i_int)y)>>1))) #define UINTOP(op,x,y) MKINT((i_int)((((uintptr_t)x)>>1) op (((uintptr_t)y)>>1))) #define FLOATOP(op,x,y) MKFLOAT(vm, ((GETFLOAT(x)) op (GETFLOAT(y)))) #define FLOATBOP(op,x,y) MKINT((i_int)(((GETFLOAT(x)) op (GETFLOAT(y))))) #define ADD(x,y) (void*)(((i_int)x)+(((i_int)y)-1)) #define MULT(x,y) (MKINT((((i_int)x)>>1) * (((i_int)y)>>1))) // Stack management #define INITFRAME VAL* myoldbase #define REBASE vm->valstack_base = oldbase #define RESERVE(x) if (vm->valstack_top+(x) > vm->stack_max) { stackOverflow(); } \ else { memset(vm->valstack_top, 0, (x)*sizeof(VAL)); } #define ADDTOP(x) vm->valstack_top += (x) #define TOPBASE(x) vm->valstack_top = vm->valstack_base + (x) #define BASETOP(x) vm->valstack_base = vm->valstack_top + (x) #define STOREOLD myoldbase = vm->valstack_base #define CALL(f) f(vm, myoldbase); #define TAILCALL(f) f(vm, oldbase); // Creating new values (each value placed at the top of the stack) VAL MKFLOAT(VM* vm, double val); VAL MKSTR(VM* vm, const char* str); VAL MKPTR(VM* vm, void* ptr); VAL MKMPTR(VM* vm, void* ptr, size_t size); VAL MKB8(VM* vm, uint8_t b); VAL MKB16(VM* vm, uint16_t b); VAL MKB32(VM* vm, uint32_t b); VAL MKB64(VM* vm, uint64_t b); // SSE Vectors VAL MKB8x16(VM* vm, VAL v0, VAL v1, VAL v2, VAL v3, VAL v4, VAL v5, VAL v6, VAL v7, VAL v8, VAL v9, VAL v10, VAL v11, VAL v12, VAL v13, VAL v14, VAL v15); VAL MKB8x16const(VM* vm, uint8_t v0, uint8_t v1, uint8_t v2, uint8_t v3, uint8_t v4, uint8_t v5, uint8_t v6, uint8_t v7, uint8_t v8, uint8_t v9, uint8_t v10, uint8_t v11, uint8_t v12, uint8_t v13, uint8_t v14, uint8_t v15); VAL MKB16x8(VM* vm, VAL v0, VAL v1, VAL v2, VAL v3, VAL v4, VAL v5, VAL v6, VAL v7); VAL MKB16x8const(VM* vm, uint16_t v0, uint16_t v1, uint16_t v2, uint16_t v3, uint16_t v4, uint16_t v5, uint16_t v6, uint16_t v7); VAL MKB32x4(VM* vm, VAL v0, VAL v1, VAL v2, VAL v3); VAL MKB32x4const(VM* vm, uint32_t v0, uint32_t v1, uint32_t v2, uint32_t v3); VAL MKB64x2(VM* vm, VAL v0, VAL v1); VAL MKB64x2const(VM* vm, uint64_t v0, uint64_t v1); // following versions don't take a lock when allocating VAL MKFLOATc(VM* vm, double val); VAL MKSTROFFc(VM* vm, StrOffset* off); VAL MKSTRc(VM* vm, char* str); VAL MKPTRc(VM* vm, void* ptr); VAL MKMPTRc(VM* vm, void* ptr, size_t size); VAL MKBUFFERc(VM* vm, Buffer* buf); char* GETSTROFF(VAL stroff); // #define SETTAG(x, a) (x)->info.c.tag = (a) #define SETARG(x, i, a) ((x)->info.c.args)[i] = ((VAL)(a)) #define GETARG(x, i) ((x)->info.c.args)[i] void PROJECT(VM* vm, VAL r, int loc, int arity); void SLIDE(VM* vm, int args); void* allocate(size_t size, int outerlock); // void* allocCon(VM* vm, int arity, int outerlock); // When allocating from C, call 'idris_requireAlloc' with a size to // guarantee that no garbage collection will happen (and hence nothing // will move) until at least size bytes have been allocated. // idris_doneAlloc *must* be called when allocation from C is done (as it // may take a lock if other threads are running). void idris_requireAlloc(size_t size); void idris_doneAlloc(); // public interface to allocation (note that this may move other pointers // if allocating beyond the limits given by idris_requireAlloc!) // 'realloc' just calls alloc and copies; 'free' does nothing void* idris_alloc(size_t size); void* idris_realloc(void* old, size_t old_size, size_t size); void idris_free(void* ptr, size_t size); #define allocCon(cl, vm, t, a, o) \ cl = allocate(sizeof(Closure) + sizeof(VAL)*a, o); \ SETTY(cl, CON); \ cl->info.c.tag_arity = ((t) << 8) | (a); #define updateCon(cl, old, t, a) \ cl = old; \ SETTY(cl, CON); \ cl->info.c.tag_arity = ((t) << 8) | (a); #define NULL_CON(x) nullary_cons[x] extern VAL* nullary_cons; void init_nullaries(); void free_nullaries(); void* vmThread(VM* callvm, func f, VAL arg); // Copy a structure to another vm's heap VAL copyTo(VM* newVM, VAL x); // Add a message to another VM's message queue void idris_sendMessage(VM* sender, VM* dest, VAL msg); // Check whether there are any messages in the queue and return PID of // sender if so (null if not) VM* idris_checkMessages(VM* vm); // Check whether there are any messages in the queue VM* idris_checkMessagesFrom(VM* vm, VM* sender); // block until there is a message in the queue Msg* idris_recvMessage(VM* vm); // block until there is a message in the queue Msg* idris_recvMessageFrom(VM* vm, VM* sender); // Query/free structure used to return message data (recvMessage will malloc, // so needs an explicit free) VAL idris_getMsg(Msg* msg); VM* idris_getSender(Msg* msg); void idris_freeMsg(Msg* msg); void dumpVal(VAL r); void dumpStack(VM* vm); // Casts #define idris_castIntFloat(x) MKFLOAT(vm, (double)(GETINT(x))) #define idris_castFloatInt(x) MKINT((i_int)(GETFLOAT(x))) VAL idris_castIntStr(VM* vm, VAL i); VAL idris_castBitsStr(VM* vm, VAL i); VAL idris_castStrInt(VM* vm, VAL i); VAL idris_castFloatStr(VM* vm, VAL i); VAL idris_castStrFloat(VM* vm, VAL i); // Raw memory manipulation void idris_memset(void* ptr, i_int offset, uint8_t c, i_int size); uint8_t idris_peek(void* ptr, i_int offset); void idris_poke(void* ptr, i_int offset, uint8_t data); void idris_memmove(void* dest, void* src, i_int dest_offset, i_int src_offset, i_int size); // String primitives VAL idris_concat(VM* vm, VAL l, VAL r); VAL idris_strlt(VM* vm, VAL l, VAL r); VAL idris_streq(VM* vm, VAL l, VAL r); VAL idris_strlen(VM* vm, VAL l); VAL idris_readStr(VM* vm, FILE* h); VAL idris_strHead(VM* vm, VAL str); VAL idris_strTail(VM* vm, VAL str); VAL idris_strCons(VM* vm, VAL x, VAL xs); VAL idris_strIndex(VM* vm, VAL str, VAL i); VAL idris_strRev(VM* vm, VAL str); // Buffer primitives VAL idris_buffer_allocate(VM* vm, VAL hint); VAL idris_appendBuffer(VM* vm, VAL fst, VAL fstLen, VAL cnt, VAL sndLen, VAL sndOff, VAL snd); VAL idris_appendB8Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB16Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB16LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB16BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB32Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB32LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB32BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB64Native(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB64LE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_appendB64BE(VM* vm, VAL buf, VAL len, VAL cnt, VAL val); VAL idris_peekB8Native(VM* vm, VAL buf, VAL off); VAL idris_peekB16Native(VM* vm, VAL buf, VAL off); VAL idris_peekB16LE(VM* vm, VAL buf, VAL off); VAL idris_peekB16BE(VM* vm, VAL buf, VAL off); VAL idris_peekB32Native(VM* vm, VAL buf, VAL off); VAL idris_peekB32LE(VM* vm, VAL buf, VAL off); VAL idris_peekB32BE(VM* vm, VAL buf, VAL off); VAL idris_peekB64Native(VM* vm, VAL buf, VAL off); VAL idris_peekB64LE(VM* vm, VAL buf, VAL off); VAL idris_peekB64BE(VM* vm, VAL buf, VAL off); // system infox // used indices: // 0 returns backend // 1 returns OS VAL idris_systemInfo(VM* vm, VAL index); // Command line args extern int __idris_argc; extern char **__idris_argv; int idris_numArgs(); const char *idris_getArg(int i); // Handle stack overflow. // Just reports an error and exits. void stackOverflow(); // I think these names are nicer for an API... #define idris_constructor allocCon #define idris_setConArg SETARG #define idris_getConArg GETARG #define idris_mkInt(x) MKINT((intptr_t)(x)) #include "idris_gmp.h" #endif