/* Copyright 2023,2024,2025 Lennart Augustsson * See LICENSE file for full license. */ #include "mhsffi.h" /* this includes config.h */ #include "extra.c" #if !defined(WANT_GMP) #define WANT_GMP 0 #endif /* defined(WANT_GMP) */ #include #include #include #include #include #if WANT_MATH #include #endif /* WANT_MATH */ #if defined(__EMSCRIPTEN__) #include "emscripten.h" #endif /* __EMSCRIPTEN__ */ #if WANT_DIR #include #include #include #include #endif /* WANT_DIR */ #if WANT_TIME #include #endif #if WANT_GMP #include #endif #if WANT_SIGINT #include #endif extern char **environ; /* should probably be behind some WANT_ */ #if WANT_MD5 #include "md5.h" #endif #if !defined(WANT_UTF8) #define WANT_UTF8 1 #endif #if !defined(WANT_BUF) #define WANT_BUF 1 #endif #if !defined(WANT_CRLF) #define WANT_CRLF 1 #endif #if !defined(WANT_BASE64) #define WANT_BASE64 1 #endif #if !defined(WANT_LZ77) #define WANT_LZ77 1 #endif #if !defined(WANT_RLE) #define WANT_RLE 1 #endif #if !defined(WANT_BWT) #define WANT_BWT 1 #endif #if !defined(WANT_ERRNO) #define WANT_ERRNO 0 #else #include #endif #define NEED_INT64 (WANT_INT64 && WORD_SIZE == 32) #if WANT_LZ77 size_t lz77d(uint8_t *src, size_t srclen, uint8_t **bufp); size_t lz77c(uint8_t *src, size_t srclen, uint8_t **bufp); #endif #if defined(__GNUC__) && __GNUC__ >= 14 && defined(__aarch64__) #define REGISTER(dcl, reg) register dcl asm(#reg) #else #define REGISTER(dcl, reg) dcl #endif const struct ffi_entry ffi_table[]; int num_ffi; #define FFI_IX(i) ((i) < num_ffi ? ffi_table[i] : xffi_table[i - num_ffi]) #if WANT_STDIO #define THREAD_DEBUG 1 #else #define THREAD_DEBUG 0 #endif #define VERSION "v8.3\n" #define PRIvalue PRIdPTR #define PRIuvalue PRIuPTR typedef uintptr_t heapoffs_t; /* Heap offsets */ #define PRIheap PRIuPTR typedef uintptr_t tag_t; /* Room for tag, low order bit indicates AP/not-AP */ typedef uintptr_t counter_t; /* Statistics counter, can be smaller since overflow doesn't matter */ #define PRIcounter PRIuPTR typedef uintptr_t bits_t; /* One word of bits */ #if !defined(WANT_ARGS) #define WANT_ARGS 1 #endif #if !defined(MALLOC) #define MALLOC malloc #endif #if !defined(REALLOC) #define REALLOC realloc #endif #if !defined(CALLOC) #define CALLOC calloc #endif #if !defined(FREE) #define FREE free #endif #if !defined(EXIT) #define EXIT exit #endif #if !defined(PRINT) #define PRINT printf #endif #if !defined(PCOMMA) #define PCOMMA "'" #endif /* !defined(PCOMMA) */ #if !defined(GETRAW) int GETRAW(void) { return -1; } #endif /* !defined(GETRAW) */ #if !defined(GETTIMEMILLI) value_t GETTIMEMILLI(void) { return 0; } #endif /* !define(GETTIMEMILLI) */ #if !defined(GETCPUTIME) void GETCPUTIME(long *sec, long *nsec) { sec = 0; nsec = 0; } #endif /* !define(GETCPUTIME) */ #if !defined(INLINE) #define INLINE inline #endif /* !define(INLINE) */ #if !defined(NORETURN) /*#define NORETURN [[noreturn]]*/ #define NORETURN _Noreturn #endif /* !defined(NORETURN) */ #if !defined(PACKED) #if WORD_SIZE == 32 #define PACKED __attribute__((packed)) #else #define PACKED #endif /* WORD_SIZE == 32 */ #endif /* !defined(PACKED) */ #if !defined(SLICE) #define SLICE 100000 #endif NORETURN void memerr(void); void * mmalloc(size_t s) { void *p = MALLOC(s); if (!p) memerr(); return p; } void * mrealloc(void *q, size_t s) { void *p = REALLOC(q, s); if (!p) memerr(); return p; } void * mcalloc(size_t n, size_t s) { void *p = CALLOC(n, s); if (!p) memerr(); return p; } #if !defined(ERR) #if WANT_STDIO #define ERR(s) do { fprintf(stderr,"ERR: "s"\n"); EXIT(1); } while(0) #define ERR1(s,a) do { fprintf(stderr,"ERR: "s"\n",a); EXIT(1); } while(0) #else /* WANT_STDIO */ #define ERR(s) EXIT(1) #define ERR1(s,a) EXIT(1) #endif /* WANT_STDIO */ #endif /* !define(ERR) */ #if !defined(TMPNAME) /* This is a really bad implementation, since it doesn't check for anything. */ char* TMPNAME(const char* pre, const char* suf) { ERR("no TMPNAME"); } #endif #if !defined(FFS) /* This is pretty bad, could use deBruijn multiplication instead. */ int FFS(bits_t x) { int i; if (!x) return 0; for(i = 1; !(x & 1); x >>= 1, i++) ; return i; } #endif /* !defined(FFS) */ /***** popcount *****/ #if defined(__has_builtin) #if __has_builtin(__builtin_popcountl) #define BUILTIN_POPCOUNT __builtin_popcountl #endif #if __has_builtin(__builtin_popcountll) #define BUILTIN_POPCOUNT64 __builtin_popcountll #endif #endif #if !defined(POPCOUNT) uvalue_t POPCOUNT(uvalue_t x) { #if defined(BUILTIN_POPCOUNT) return BUILTIN_POPCOUNT(x); #else /* !defined(BUILTIN_POPCOUNT) */ uvalue_t count = 0; while (x) { x = x & (x - 1); // clear lowest 1 bit count++; } return count; #endif /* !defined(BUILTIN_POPCOUNT) */ } #endif /* !defined(POPCOUNT) */ #if !defined(POPCOUNT64) uvalue_t POPCOUNT64(uint64_t x) { #if defined(BUILTIN_POPCOUNT64) return BUILTIN_POPCOUNT64(x); #else /* !defined(BUILTIN_POPCOUNT64) */ uvalue_t count = 0; while (x) { x = x & (x - 1); // clear lowest 1 bit count++; } return count; #endif /* !defined(BUILTIN_POPCOUNT64) */ } #endif /* !defined(POPCOUNT64) */ /***** end popcount *****/ /***** clz *****/ #if defined(__has_builtin) #if __has_builtin(__builtin_clzl) #define BUILTIN_CLZ __builtin_clzl #endif #if __has_builtin(__builtin_clzll) #define BUILTIN_CLZ64 __builtin_clzll #endif #endif #if !defined(CLZ) uvalue_t CLZ(uvalue_t x) { #if defined(BUILTIN_CLZ) if (x == 0) return WORD_SIZE; return BUILTIN_CLZ(x); #else /* defined(BUILTIN_CLZ) */ value_t count = WORD_SIZE; while (x) { x = x >> 1; count--; } return count; #endif /* defined(BUILTIN_CLZ) */ } #endif /* !defined(CLZ) */ #if !defined(CLZ64) uvalue_t CLZ64(uint64_t x) { #if defined(BUILTIN_CLZ64) if (x == 0) return 64; return BUILTIN_CLZ64(x); #else /* defined(BUILTIN_CLZ64) */ value_t count = 64; while (x) { x = x >> 1; count--; } return count; #endif /* defined(BUILTIN_CLZ64) */ } #endif /* !defined(CLZ64) */ /***** end clz *****/ /***** ctz *****/ #if defined(__has_builtin) #if __has_builtin(__builtin_ctzl) #define BUILTIN_CTZ __builtin_ctzl #endif #if __has_builtin(__builtin_ctzl) #define BUILTIN_CTZ64 __builtin_ctzll #endif #endif /* defined(__has_builtin) */ #if !defined(CTZ) uvalue_t CTZ(uvalue_t x) { if (x == 0) return WORD_SIZE; #if defined(BUILTIN_CTZ) return BUILTIN_CTZ(x); #else /* defined(BUILTIN_CTZ) */ uvalue_t count = 0; while ((x & 1) == 0) { x = x >> 1; count += 1; } return count; #endif /* defined(BUILTIN_CTZ) */ } #endif /* !defined(CTZ) */ #if !defined(CTZ64) uvalue_t CTZ64(uint64_t x) { if (x == 0) return 64; #if defined(BUILTIN_CTZ64) return BUILTIN_CTZ64(x); #else /* defined(BUILTIN_CTZ64) */ uvalue_t count = 0; while ((x & 1) == 0) { x = x >> 1; count++; } return count; #endif /* defined(BUILTIN_CTZ64) */ } #endif /* !defined(CTZ) */ /***** end ctz *****/ #if !defined(COUNT) #define COUNT(n) ++(n) #endif value_t iswindows(void) { #if defined(ISWINDOWS) return 1; #else return 0; #endif } value_t ismacos(void) { #if defined(ISMACOS) return 1; #else return 0; #endif } value_t islinux(void) { #if defined(ISLINUX) return 1; #else return 0; #endif } /***************************************/ /* Keep permanent nodes for LOW_INT <= i < HIGH_INT */ #define LOW_INT (-10) #define HIGH_INT 256 #if !defined(HEAP_CELLS) #define HEAP_CELLS 50000000 #endif #if !defined(STACK_SIZE) #define STACK_SIZE 200000 #endif /* tcc doesn't understand noreturn attribute */ #if defined(__TCC__) #define NOTREACHED return 0 #else #define NOTREACHED #endif enum node_tag { T_FREE, T_IND, T_AP, T_INT, T_INT64X, T_DBL, T_FLT32, T_PTR, T_FUNPTR, T_FORPTR, T_BADDYN, T_ARR, T_THID, T_MVAR, T_WEAK, T_S, T_K, T_I, T_B, T_C, T_A, T_Y, T_SS, T_BB, T_CC, T_P, T_R, T_O, T_U, T_Z, T_J, T_K2, T_K3, T_K4, T_CCB, T_ADD, T_SUB, T_MUL, T_QUOT, T_REM, T_SUBR, T_UQUOT, T_UREM, T_NEG, T_AND, T_OR, T_XOR, T_INV, T_SHL, T_SHR, T_ASHR, T_POPCOUNT, T_CLZ, T_CTZ, T_EQ, T_NE, T_LT, T_LE, T_GT, T_GE, T_ULT, T_ULE, T_UGT, T_UGE, T_ICMP, T_UCMP, T_ADD64, T_SUB64, T_MUL64, T_QUOT64, T_REM64, T_SUBR64, T_UQUOT64, T_UREM64, T_NEG64, T_AND64, T_OR64, T_XOR64, T_INV64, T_SHL64, T_SHR64, T_ASHR64, T_POPCOUNT64, T_CLZ64, T_CTZ64, T_EQ64, T_NE64, T_LT64, T_LE64, T_GT64, T_GE64, T_ULT64, T_ULE64, T_UGT64, T_UGE64, T_ICMP64, T_UCMP64, T_ITOI64, T_I64TOI, T_UTOU64, T_U64TOU, T_FPADD, T_FP2P, T_FPNEW, T_FPFIN, T_FP2BS, T_BS2FP, T_TOPTR, T_TOINT, T_TODBL, T_TOFLT, T_TOFUNPTR, T_FROMDBL, T_FROMFLT, T_BININT2, T_BININT1, T_UNINT1, T_BININT64_2, T_BININT64_1, T_UNINT64_1, T_BINFLT2, T_BINFLT1, T_UNFLT1, T_BINDBL2, T_BINDBL1, T_UNDBL1, T_BINBS2, T_BINBS1, T_ISINT, T_FADD, T_FSUB, T_FMUL, T_FDIV, T_FNEG, T_ITOF, T_I64TOF, T_FEQ, T_FNE, T_FLT, T_FLE, T_FGT, T_FGE, T_DADD, T_DSUB, T_DMUL, T_DDIV, T_DNEG, T_ITOD, T_I64TOD, T_DEQ, T_DNE, T_DLT, T_DLE, T_DGT, T_DGE, T_ARR_ALLOC, T_ARR_COPY, T_ARR_SIZE, T_ARR_READ, T_ARR_WRITE, T_ARR_TRUNC, T_ARR_EQ, T_RAISE, T_SEQ, T_RNF, T_TICK, T_IO_BIND, T_IO_THEN, T_IO_RETURN, T_IO_SERIALIZE, T_IO_DESERIALIZE, T_IO_GETARGREF, T_IO_PERFORMIO, T_IO_PRINT, T_CATCH, T_CATCHR, T_IO_CCALL, T_IO_GC, T_IO_STATS, T_DYNSYM, T_IO_FORK, T_IO_THID, T_THNUM, T_IO_THROWTO, T_IO_YIELD, T_IO_NEWMVAR, T_IO_TAKEMVAR, T_IO_PUTMVAR, T_IO_READMVAR, T_IO_TRYTAKEMVAR, T_IO_TRYPUTMVAR, T_IO_TRYREADMVAR, T_IO_THREADDELAY, T_IO_THREADSTATUS, T_IO_GETMASKINGSTATE, T_IO_SETMASKINGSTATE, T_NEWCASTRINGLEN, T_PACKCSTRING, T_PACKCSTRINGLEN, T_BSAPPEND, T_BSEQ, T_BSNE, T_BSLT, T_BSLE, T_BSGT, T_BSGE, T_BSCMP, T_BSPACK, T_BSUNPACK, T_BSREPLICATE, T_BSLENGTH, T_BSSUBSTR, T_BSINDEX, T_BSWRITE, T_BSFROMUTF8, T_BSTOUTF8, T_BSHEADUTF8, T_BSTAILUTF8, T_BSAPPENDDOT, T_BSGRAB, T_SPNEW, T_SPDEREF, T_SPFREE, T_WKNEWFIN, T_WKNEW, T_WKDEREF, T_WKFINAL, T_IO_PP, /* for debugging */ T_IO_STDIN, T_IO_STDOUT, T_IO_STDERR, T_LAST_TAG, }; #if WANT_TAGNAMES /* Most entries are initialized from the primops table. */ static const char* tag_names [T_LAST_TAG+1] = { "FREE", "IND", "AP", "INT", "INT64", "DBL", "FLT32", "PTR", "FUNPTR", "FORPTR", "BADDYN", "ARR", "THID", "MVAR", "WEAK" }; #define TAGNAME(t) tag_names[t] #else #define TAGNAME(t) "?" #endif /* On 64 bit platforms there is no special type for Int64 */ #if NEED_INT64 #define T_INT64 T_INT64X #else #define T_INT64 T_INT #endif /* WORD_SIZE == 64 */ struct ioarray; struct bytestring; struct forptr; struct mthread; struct mvar; struct weak_ptr; typedef struct PACKED node { union { struct node *uufun; intptr_t uuifun; tag_t uutag; /* LSB=1 indicates that this is a tag, LSB=0 that this is a T_AP node */ } ufun; union { struct node *uuarg; value_t uuvalue; #if WANT_FLOAT32 flt32_t uuflt32value; uint32_t uuint32value; #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 flt64_t uuflt64value; #endif /* WANT_FLOAT32 */ #if WANT_INT64 int64_t uuint64value; #endif /* WANT_INT64 */ const char *uucstring; void *uuptr; HsFunPtr uufunptr; struct ioarray *uuarray; struct forptr *uuforptr; /* foreign pointers and byte arrays */ struct mthread *uuthread; struct mvar *uumvar; struct weak_ptr *uuweak; } uarg; } node; #define BIT_TAG 1 #define BIT_IND 2 #define BIT_NOTAP (BIT_TAG | BIT_IND) #define TAG_SHIFT 2 #define NIL 0 #define HEAPREF(i) &cells[(i)] #define GETTAG(p) ((p)->ufun.uutag & BIT_NOTAP ? ( (p)->ufun.uutag & BIT_IND ? T_IND : (int)((p)->ufun.uutag >> TAG_SHIFT) ) : T_AP) #define SETTAG(p,t) do { if (t != T_AP) { if (t == T_IND) { (p)->ufun.uutag = BIT_IND; } else { (p)->ufun.uutag = ((t) << TAG_SHIFT) | BIT_TAG; } } } while(0) #define GETVALUE(p) (p)->uarg.uuvalue #define GETINT64VALUE(p) (p)->uarg.uuint64value #define GETINT32VALUE(p) (p)->uarg.uuint32value #define GETFLTVALUE(p) (p)->uarg.uuflt32value #define GETDBLVALUE(p) (p)->uarg.uuflt64value #define SETVALUE(p,v) (p)->uarg.uuvalue = v #define SETINT64VALUE(p,v) (p)->uarg.uuint64value = v #define SETINT32VALUE(p,v) (p)->uarg.uuint32value = v #define SETFLTVALUE(p,v) (p)->uarg.uuflt32value = v #define SETDBLVALUE(p,v) (p)->uarg.uuflt64value = v #define FUN(p) (p)->ufun.uufun #define ARG(p) (p)->uarg.uuarg #define CSTR(p) (p)->uarg.uucstring #define PTR(p) (p)->uarg.uuptr #define FUNPTR(p) (p)->uarg.uufunptr #define FORPTR(p) (p)->uarg.uuforptr #define BSTR(p) (p)->uarg.uuforptr->payload #define ARR(p) (p)->uarg.uuarray #define THR(p) (p)->uarg.uuthread #define MVAR(p) (p)->uarg.uumvar #define ISINDIR(p) ((p)->ufun.uuifun & BIT_IND) #define WEAK(p) (p)->uarg.uuweak #define GETINDIR(p) ((struct node*) ((p)->ufun.uuifun & ~BIT_IND)) #define SETINDIR(p,q) do { (p)->ufun.uuifun = (intptr_t)(q) | BIT_IND; } while(0) #define NODE_SIZE sizeof(node) #define ALLOC_HEAP(n) do { cells = mmalloc(n * sizeof(node)); } while(0) #define LABEL(n) ((heapoffs_t)((n) - cells)) node *cells; /* All cells */ /* * byte arrays */ struct bytestring { size_t size; void *string; }; /* * Arrays are allocated with malloc()/free(). * During GC they are marked, and all elements in the array are * recursively marked. * At the end of the the mark phase there is a scan of all * arrays, and the unmarked ones are freed. */ struct ioarray { struct ioarray *next; /* all ioarrays are linked together */ bool permanent; /* this array should never be GC-ed */ size_t marked; /* marked during GC */ size_t size; /* number of elements in the array */ NODEPTR array[1]; /* actual size may be bigger */ }; struct ioarray *array_root = 0; /* root of all allocated arrays, linked by next */ enum fptype { FP_FORPTR = 0, /* a regular foreign pointer to unknown memory */ FP_BSTR, /* a bytestring */ FP_MPZ, /* a GMP MPZ pointer */ }; /* * A Haskell ForeignPtr has a normal pointer, and a finalizer * function that is to be called when there are no more references * to the ForeignPtr. * A complication is that using plusForeignPtr creates a new * ForeignPtr that must share the same finalizer. * There is one struct forptr for each ForeignPtr. It has pointer * to the actual data, and to a struct final which is shared between * all ForeignPtrs that have been created with plusForeignPtr. * During GC the used bit is set for any references to the forptr. * The scan phase will traverse the struct final chain and run * the finalizer, and free associated structs. */ struct final { struct final *next; /* the next finalizer */ HsFunPtr final; /* function to call to release resource */ void *arg; /* argument to final when called */ size_t size; /* size of memory, if known, otherwise NOSIZE */ #define NOSIZE ~0 /* used as the size in payload for actual foreign pointers */ struct forptr *back; /* back pointer to the first forptr */ short marked; /* mark bit for GC */ enum fptype fptype; /* what kind of foreign pointer */ }; /* * Foreign pointers are also used to represent bytestrings. * The difference between a foreign pointer and a bytestring * is that we can serialize the latter. * The size field is non-zero only for bytestrings. */ struct forptr { struct forptr *next; /* the next ForeignPtr that shares the same finalizer */ struct final *finalizer; /* the finalizer for this ForeignPtr */ struct bytestring payload; /* the actual pointer to allocated data, and maybe a size */ // char *desc; }; struct final *final_root = 0; /* root of all allocated foreign pointers, linked by next */ //REGISTER(counter_t num_reductions,r19); counter_t num_reductions = 0; counter_t num_alloc = 0; counter_t num_gc = 0; counter_t num_yield = 0; counter_t num_resched = 0; counter_t num_thread_reap = 0; counter_t num_mvar_alloc = 0; counter_t num_mvar_free = 0; counter_t num_stable_alloc = 0; counter_t num_stable_free = 0; counter_t num_new_weak = 0; counter_t num_gc_weak = 0; uintptr_t gc_mark_time = 0; uintptr_t gc_scan_time = 0; uintptr_t run_time = 0; #define MAIN_THREAD 1 uvalue_t num_thread_create = MAIN_THREAD; #define MAXSTACKDEPTH 0 #if MAXSTACKDEPTH stackptr_t max_stack_depth = 0; counter_t max_c_stack = 0; counter_t cur_c_stack = 0; #define MAXSTACK if (stack_ptr > max_stack_depth) max_stack_depth = stack_ptr #else #define MAXSTACK #endif NODEPTR atptr; REGISTER(NODEPTR *stack,r20); REGISTER(stackptr_t stack_ptr,r21); #if STACKOVL #define PUSH(x) do { if (stack_ptr >= stack_size-2) stackerr(); stack[++stack_ptr] = (x); MAXSTACK; } while(0) #else /* STACKOVL */ #define PUSH(x) do { stack[++stack_ptr] = (x); MAXSTACK; } while(0) #endif /* STACKOVL */ #define TOP(n) stack[stack_ptr - (n)] #define POP(n) stack_ptr -= (n) #define POPTOP() stack[stack_ptr--] #define GCCHECK(n) gc_check((n)) #define CLEARSTK() do { stack_ptr = -1; } while(0) #define GCCHECKSAVE(p, n) do { PUSH(p); GCCHECK(n); (p) = TOP(0); POP(1); } while(0) heapoffs_t heap_size; /* number of heap cells */ heapoffs_t heap_start; /* first location in heap that needs GC */ REGISTER(stackptr_t stack_size,r22); /* number of stack slots */ counter_t num_marked; counter_t max_num_marked = 0; counter_t num_free; counter_t num_arr_alloc; counter_t num_arr_free; counter_t num_fin_alloc; counter_t num_fin_free; counter_t num_bs_alloc; counter_t num_bs_alloc_max; counter_t num_bs_free; counter_t num_bs_bytes; counter_t num_bs_inuse; counter_t num_bs_inuse_max; #define BITS_PER_WORD (sizeof(bits_t) * 8) bits_t *free_map; /* 1 bit per node, 0=free, 1=used */ heapoffs_t free_map_nwords; heapoffs_t next_scan_index; int want_gc_red = 0; NORETURN void memerr(void) { ERR("Out of memory"); } NORETURN void stackerr(void) { ERR("stack overflow"); } /***************************************/ #include "bfile.c" /***************************************/ struct ioarray* arr_alloc(size_t sz, NODEPTR e) { struct ioarray *arr = mmalloc(sizeof(struct ioarray) + (sz-1) * sizeof(NODEPTR)); size_t i; arr->next = array_root; array_root = arr; arr->marked = 0; arr->permanent = false; arr->size = sz; for(i = 0; i < sz; i++) arr->array[i] = e; //PRINT("arr_alloc(%d, %p) = %p\n", (int)sz, e, arr); num_arr_alloc++; return arr; } struct ioarray* arr_copy(struct ioarray *oarr) { size_t sz = oarr->size; struct ioarray *arr = mmalloc(sizeof(struct ioarray) + (sz-1) * sizeof(NODEPTR)); arr->next = array_root; array_root = arr; arr->marked = 0; arr->permanent = false; arr->size = sz; memcpy(arr->array, oarr->array, sz * sizeof(NODEPTR)); num_arr_alloc++; return arr; } /*****************************************************************************/ #if WANT_TICK struct tick_entry { struct bytestring tick_name; counter_t tick_count; } *tick_table = 0; size_t tick_table_size; size_t tick_index; /* Allocate a new tick table entry and return the index. */ size_t add_tick_table(struct bytestring name) { if (!tick_table) { tick_table_size = 100; tick_table = mmalloc(tick_table_size * sizeof(struct tick_entry)); tick_index = 0; } if (tick_index >= tick_table_size) { tick_table_size *= 2; tick_table = mrealloc(tick_table, tick_table_size * sizeof(struct tick_entry)); } tick_table[tick_index].tick_name = name; tick_table[tick_index].tick_count = 0; return tick_index++; } /* Called with the tick index. */ static inline void dotick(value_t i) { tick_table[i].tick_count++; } void dump_tick_table(FILE *f) { if (!tick_table) { fprintf(f, "Tick table empty\n"); return; } for (size_t i = 0; i < tick_index; i++) { counter_t n = tick_table[i].tick_count; if (n) fprintf(f, "%-60s %10"PRIcounter"\n", (char *)tick_table[i].tick_name.string, n); } } #endif enum th_sched { mt_main, mt_resched, mt_raise }; /* The two enums below are known by the Haskell code. Do not change order */ enum th_state { ts_runnable, ts_wait_mvar, ts_wait_time, ts_finished, ts_died }; enum mask_state { mask_unmasked, mask_interruptible, mask_uninterruptible }; /***************** HANDLER *****************/ struct handler { jmp_buf hdl_buf; /* env storage */ struct handler *hdl_old; /* old handler */ NODEPTR hdl_exn; /* used temporarily to pass the exception value */ } *cur_handler = 0; /***************** THREAD ******************/ struct mthread { enum th_state mt_state; /* thread state */ enum mask_state mt_mask; /* making state. */ struct mthread *mt_next; /* all threads linked together */ struct mthread *mt_queue; /* runq/waitq link */ counter_t mt_slice; /* reduction steps until yielding */ counter_t mt_num_slices; /* number of slices so far */ NODEPTR mt_root; /* root of the graph to reduce */ struct mvar *mt_exn; /* possible thrown exception */ NODEPTR mt_mval; /* filled after waiting for take/read */ bool mt_mark; /* marked as accessible */ uvalue_t mt_id; /* thread number, thread 1 is the main thread */ #if defined(CLOCK_INIT) CLOCK_T mt_at; /* time to wake up when in threadDelay */ #endif }; struct mthread *all_threads = 0; /* all threads */ struct mqueue { struct mthread *mq_head; struct mthread *mq_tail; }; struct mqueue runq = { 0, 0 };; struct mqueue timeq = { 0, 0 }; struct mvar { struct mvar *mv_next; /* all mvars linked together */ NODEPTR mv_data; /* contents of the mvar, or NIL when empty */ struct mqueue mv_takeput; /* queue of threads waiting for take or put, single wakeup */ struct mqueue mv_read; /* queue of threads waiting for read, multiple wakeup */ bool mv_mark; /* marked as accessible */ }; struct mvar *all_mvars = 0; /* all mvars */ jmp_buf sched; /* jump here to yield */ counter_t slice = SLICE; /* normal time slice; * on an M4 Mac this is about 0.3ms */ //REGISTER(counter_t glob_slice,r23); REGISTER(int glob_slice,r23); NODEPTR the_exn; /* Used to propagate the exception for longjmp(sched, mt_raise) */ /****** StablePtr ******/ size_t sp_capacity = 4; /* size of stable pointer table */ NODEPTR *sp_table; /* stable pointer table */ static void init_stableptr(void) { sp_table = mmalloc(sp_capacity * sizeof(NODEPTR)); /* stable pointer table, all free */ for (size_t i = 0; i < sp_capacity; i++) sp_table[i] = NIL; } static uvalue_t new_stableptr(NODEPTR n) { size_t i; COUNT(num_stable_alloc); /* Linear search for an empty slot. */ /* Not ideal, but fine for a small number of StablePtr. */ for(i = 1; i < sp_capacity; i++) { /* index 0 reserved according to the spec */ if (sp_table[i] == NIL) break; } if (i == sp_capacity) { /* table is full, so double its size */ sp_capacity *= 2; sp_table = mrealloc(sp_table, sp_capacity * sizeof(NODEPTR)); for(size_t j = i; j < sp_capacity; j++) sp_table[j] = NIL; } sp_table[i] = n; return (uvalue_t)i; } static NODEPTR deref_stableptr(uvalue_t sp) { if (sp_table[sp] == NIL || sp >= sp_capacity) ERR("deref_stableptr"); return sp_table[sp]; } static void free_stableptr(uvalue_t sp) { if (sp_table[sp] == NIL || sp >= sp_capacity) ERR("free_stableptr"); COUNT(num_stable_free); sp_table[sp] = NIL; } /* The order of these must be kept in sync with Control.Exception.Internal.rtsExn */ enum rts_exn { exn_stackoverflow, exn_heapoverflow, exn_threadkilled, exn_userinterrupt, exn_dividebyzero, exn_blockedmvar, exn_blockedstm }; NORETURN void raise_exn(NODEPTR exn); struct mvar* new_mvar(void); NODEPTR take_mvar(bool try, struct mvar *mv); NORETURN void die_exn(NODEPTR exn); void thread_intr(struct mthread *mt); int put_mvar(bool try, struct mvar *mv, NODEPTR v); NODEPTR mkInt(value_t i); NODEPTR mkInt64(int64_t i); NODEPTR mkFlt32(flt32_t d); NODEPTR mkFlt64(flt64_t d); NODEPTR mkPtr(void* p); struct mthread* new_thread(NODEPTR root); void gc(void); void async_throwto(struct mthread*, NODEPTR); #if WANT_STDIO void pp(FILE*, NODEPTR); #endif /* Needed during reduction */ NODEPTR intTable[HIGH_INT - LOW_INT]; NODEPTR combK, combTrue, combI, combCons, combPair; NODEPTR combCC, combZ, combIOBIND, combIORETURN, combIOTHEN, combB, combC, combBB; NODEPTR combSETMASKINGSTATE; NODEPTR combLT, combEQ, combGT; NODEPTR combPERFORMIO; NODEPTR combShowExn, combU, combK2, combK3; NODEPTR combBININT1, combBININT2, combUNINT1; NODEPTR combBININT64_1, combBININT64_2, combUNINT64_1; NODEPTR combBINFLT1, combBINFLT2, combUNFLT1; NODEPTR combBINDBL1, combBINDBL2, combUNDBL1; NODEPTR combBINBS1, combBINBS2; NODEPTR comb_stdin, comb_stdout, comb_stderr; NODEPTR combJust; NODEPTR combTHROWTO; NODEPTR combPairUnit; NODEPTR combWorld; NODEPTR combCATCHR; #define combFalse combK #define combNothing combK #define combUnit combI /*******************************/ #if WANT_ARGS /* This single element array hold a list of the program arguments. */ struct ioarray *argarray; #endif /* WANT_ARGS */ int verbose = 0; int gcbell = 0; #if WANT_SIGINT volatile bool has_sigint = false; void handle_sigint(int s) { has_sigint = true; } #endif /* Check that there are k nodes available, if not then GC. */ INLINE void gc_check(size_t k) { if (k < num_free) return; #if WANT_STDIO if (verbose > 1) PRINT("gc_check: %d\n", (int)k); #endif gc(); } /* Add the thread to the tail of runq */ void add_q_tail(struct mqueue *q, struct mthread *mt) { if (!q->mq_head) { /* q is empty, so mt goes first */ q->mq_head = mt; } else { /* link mt to the end of the runq */ q->mq_tail->mt_queue = mt; } q->mq_tail = mt; /* mt is now last */ mt->mt_queue = 0; /* mt is last, so no next */ } void add_runq_tail(struct mthread *mt) { mt->mt_state = ts_runnable; add_q_tail(&runq, mt); } struct mthread* remove_q_head(struct mqueue *q) { struct mthread *mt = q->mq_head; /* front thread */ if (!mt) return 0; q->mq_head = mt->mt_queue; /* skip to next thread */ if (!q->mq_head) q->mq_tail = 0; /* q is now empty */ return mt; } int find_and_unlink(struct mqueue *mq, struct mthread *mt) { struct mthread **mtp; for(mtp = &mq->mq_head; *mtp && *mtp != mt; mtp = &(*mtp)->mt_queue) ; if (!*mtp) return 0; /* not found */ *mtp = mt->mt_queue; /* unlink */ if (*mtp) return 1; /* the unlinked thread was not the tail */ if (mq->mq_head) { for (mt = mq->mq_head; mt->mt_queue; mt = mt->mt_queue) ; /* find the last element */ mq->mq_tail = mt; } else { /* q is empty */ mq->mq_tail = 0; } return 1; } /* This is a yucky hack */ bool doing_rnf = false; /* REMOVE */ #if THREAD_DEBUG const bool thread_trace = false; #endif /* THREAD_DEBUG */ /* clean up temporary globals to prepare for rescheduling */ void cleanup(struct mthread *mt, enum th_state ts) { /* We are going to reschedule, so clean up thread state: * stack pointer * error handlers */ #if THREAD_DEBUG if (thread_trace) printf("cleanup: %d state=%d\n", (int)mt->mt_id, ts); #endif /* THREAD_DEBUG */ mt->mt_slice = stack_ptr; /* we need stack_ptr reductions to just reach where we left off */ mt->mt_state = ts; CLEARSTK(); /* reset stack */ doing_rnf = false; /* free all error handlers */ for (struct handler *h = cur_handler; h; ) { struct handler *n = h; h = h->hdl_old; free(n); } cur_handler = 0; } /* reschedule, does not return */ NORETURN void resched(struct mthread *mt, enum th_state ts) { cleanup(mt, ts); longjmp(sched, mt_resched); } #if THREAD_DEBUG void dump_q(const char *s, struct mqueue q) { printf(" %s=[", s); for(struct mthread *mt = q.mq_head; mt; mt = mt->mt_queue) { printf("%d ", (int)mt->mt_id); } printf("]\n"); } #endif /* THREAD_DEBUG */ /* Check if its time to wake up some threads waiting for a time. */ void check_timeq(void) { #if defined(CLOCK_INIT) CLOCK_T now = CLOCK_GET(); while (timeq.mq_head && timeq.mq_head->mt_at <= now) { struct mthread *mt = remove_q_head(&timeq); add_runq_tail(mt); mt->mt_at = -1; /* indicate that the delay has expired */ #if THREAD_DEBUG if (thread_trace) printf("check_timeq: %d done\n", (int)mt->mt_id); #endif /* THREAD_DEBUG */ } #if THREAD_DEBUG if (thread_trace) { printf("check_timeq: exit\n"); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ #endif } void throwto(struct mthread *mt, NODEPTR exn) { #if THREAD_DEBUG if (thread_trace) { printf("throwto: id=%d\n", (int)mt->mt_id); } #endif /* THREAD_DEBUG */ thread_intr(mt); if (mt->mt_state != ts_died && mt->mt_state != ts_finished) { #if THREAD_DEBUG if (thread_trace) { printf("throwto: id=%d put_mvar exn\n", (int)mt->mt_id); } #endif /* THREAD_DEBUG */ (void)put_mvar(false, mt->mt_exn, exn); /* never returns if it blocks */ } } void check_thrown(bool intr) { if (runq.mq_head->mt_exn->mv_data == NIL) return; /* no thrown exception */ if (runq.mq_head->mt_mask == mask_uninterruptible || (!intr && runq.mq_head->mt_mask == mask_interruptible)) { return; /* interrupts are masked, so don't throw */ } /* the current thread has an async exception */ #if THREAD_DEBUG if (thread_trace) printf("check_thrown: exn for %d\n", (int)runq.mq_head->mt_id); #endif /* THREAD_DEBUG */ NODEPTR exn = take_mvar(false, runq.mq_head->mt_exn); /* get the exception */ raise_exn(exn); } void check_sigint(void) { #if WANT_SIGINT if (has_sigint) { /* We have a signal, so send an async exception to the main thread */ has_sigint = false; for(struct mthread *mt= all_threads; mt; mt = mt->mt_next) { if (mt->mt_id == MAIN_THREAD) { #if THREAD_DEBUG if (thread_trace) printf("sending signal to main\n"); #endif /* THREAD_DEBUG */ async_throwto(mt, mkInt(exn_userinterrupt)); break; } } } #endif } /* Used to detect calls to error while we are already in a call to error. */ bool in_raise = false; /* Inlining makes very little difference */ /*static INLINE*/ void yield(void) { if (in_raise) /* don't context switch when we are dying */ return; COUNT(num_yield); runq.mq_head->mt_num_slices++; // XXX should check mt_thrown here if (timeq.mq_head) check_timeq(); check_thrown(false); check_sigint(); // printf("yield %p %d\n", runq, (int)stack_ptr); /* if there is nothing after in the runq then there is no need to reschedule */ if (!runq.mq_head->mt_queue) { #if THREAD_DEBUG if (thread_trace) { printf("yield: %d no other threads\n", (int)runq.mq_head->mt_id); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ glob_slice = slice; num_reductions += glob_slice-1; return; } /* Unlink from runq */ struct mthread *mt = remove_q_head(&runq); /* link into back of runq */ add_runq_tail(mt); #if THREAD_DEBUG if (thread_trace) { printf("yield: resched %d\n", (int)mt->mt_id); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ resched(mt, ts_runnable); } struct mthread* new_thread(NODEPTR root) { struct mthread *mt = mmalloc(sizeof(struct mthread)); #if THREAD_DEBUG if (thread_trace) { printf("new_thread: mt=%p root=%p\n", mt, root); } #endif /* THREAD_DEBUG */ mt->mt_mask = mask_unmasked; mt->mt_root = root; mt->mt_exn = new_mvar(); mt->mt_mval = NIL; mt->mt_slice = 0; mt->mt_mark = false; mt->mt_num_slices = 0; mt->mt_id = num_thread_create++; #if defined(CLOCK_INIT) mt->mt_at = 0; /* delay has not expired */ #endif /* add to all_threads */ mt->mt_next = all_threads; all_threads = mt; /* add to tail of runq */ add_runq_tail(mt); /* sets runnable */ #if THREAD_DEBUG if (thread_trace) { printf("new_thread: add %d to runq tail\n", (int)mt->mt_id); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ return mt; } struct mvar* new_mvar(void) { COUNT(num_mvar_alloc); struct mvar *mv = mmalloc(sizeof(struct mvar)); mv->mv_data = NIL; mv->mv_takeput.mq_head = 0; mv->mv_takeput.mq_tail = 0; mv->mv_read.mq_head = 0; mv->mv_read.mq_tail = 0; /* add to all_mvars */ mv->mv_next = all_mvars; mv->mv_mark = false; all_mvars = mv; #if THREAD_DEBUG if (thread_trace) printf("new_mvar: mvar=%p\n", mv); #endif /* THREAD_DEBUG */ return mv; } NODEPTR take_mvar(bool try, struct mvar *mv) { #if THREAD_DEBUG if (thread_trace) { printf("take_mvar: start mvar=%p\n", mv); dump_q("takeput", mv->mv_takeput); } #endif /* THREAD_DEBUG */ NODEPTR n; if ((n = runq.mq_head->mt_mval) != NIL) { #if THREAD_DEBUG if (thread_trace) printf("take_mvar: end mvar=%p got data %d\n", mv, (int)runq.mq_head->mt_id); #endif /* THREAD_DEBUG */ /* We have no data after waking up */ runq.mq_head->mt_mval = NIL; return n; /* returned the stashed data */ } if ((n = mv->mv_data) != NIL) { #if THREAD_DEBUG if (thread_trace) printf("take_mvar: mvar=%p full\n", mv); #endif /* THREAD_DEBUG */ /* mvar is full */ mv->mv_data = NIL; /* now empty */ /* move all threads waiting to put to the runq */ for(;;) { struct mthread *mt = remove_q_head(&mv->mv_takeput); if (!mt) break; #if THREAD_DEBUG if (thread_trace) { printf("take_mvar: mvar=%p wake %d\n", mv, (int)mt->mt_id); } #endif /* THREAD_DEBUG */ add_runq_tail(mt); #if THREAD_DEBUG if (thread_trace) { dump_q("runq", runq); } #endif /* THREAD_DEBUG */ } #if THREAD_DEBUG if (thread_trace) { printf("take_mvar: end mvar=%p return %p\n", mv, n); } #endif /* THREAD_DEBUG */ return n; /* return the data */ } else { #if THREAD_DEBUG if (thread_trace) printf("take_mvar: mvar=%p empty\n", mv); #endif /* THREAD_DEBUG */ /* mvar is empty */ if (try) return NIL; struct mthread *mt = remove_q_head(&runq); add_q_tail(&mv->mv_takeput, mt); #if THREAD_DEBUG if (thread_trace) { printf("take_mvar: end mvar=%p suspend %d\n", mv, (int)mt->mt_id); dump_q("runq", runq); dump_q("takeput", mv->mv_takeput); } #endif /* THREAD_DEBUG */ /* Unlink from runq */ resched(mt, ts_wait_mvar); /* never returns */ NOTREACHED; } } NODEPTR read_mvar(bool try, struct mvar *mv) { NODEPTR n; if ((n = runq.mq_head->mt_mval) != NIL) { /* We have no data after waking up */ runq.mq_head->mt_mval = NIL; return n; /* returned the stashed data */ } if ((n = mv->mv_data) != NIL) { /* mvar is full */ return n; /* return the data */ } else { /* mvar is empty */ if (try) return NIL; #if THREAD_DEBUG if (thread_trace) { printf("read_mvar: suspend %d\n", (int)runq.mq_head->mt_id); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ struct mthread *mt = remove_q_head(&runq); add_q_tail(&mv->mv_read, mt); resched(mt, ts_wait_mvar); /* never returns */ NOTREACHED; } } int put_mvar(bool try, struct mvar *mv, NODEPTR v) { #if THREAD_DEBUG if (thread_trace) { printf("put_mvar: mvar=%p\n", mv); dump_q("takeput", mv->mv_takeput); dump_q("read", mv->mv_read); } #endif /* THREAD_DEBUG */ if (mv->mv_data != NIL) { #if THREAD_DEBUG if (thread_trace) printf("put_mvar: mvar=%p full\n", mv); #endif /* THREAD_DEBUG */ /* mvar is full */ if (try) return 0; struct mthread *mt = remove_q_head(&runq); add_q_tail(&mv->mv_takeput, mt); /* put on mvar queue */ #if THREAD_DEBUG if (thread_trace) { printf("put_mvar: suspend %d\n", (int)mt->mt_id); dump_q("runq", runq); dump_q("takeput", mv->mv_takeput); } #endif /* THREAD_DEBUG */ resched(mt, ts_wait_mvar); /* never returns */ } else { #if THREAD_DEBUG if (thread_trace) printf("put_mvar: mvar=%p empty\n", mv); #endif /* THREAD_DEBUG */ /* mvar is empty */ if (mv->mv_takeput.mq_head || mv->mv_read.mq_head) { /* one or more threads are waiting */ struct mthread *mt; if ((mt = remove_q_head(&mv->mv_takeput))) { /* wake up one 'take' */ #if THREAD_DEBUG if (thread_trace) printf("put_mvar: wake-1 %d\n", (int)mt->mt_id); #endif /* THREAD_DEBUG */ add_runq_tail(mt); /* and schedule for execution later */ mt->mt_mval = v; } for(;;) { mt = remove_q_head(&mv->mv_takeput); if (!mt) break; #if THREAD_DEBUG if (thread_trace) printf("put_mvar: wake-N %d\n", (int)mt->mt_id); #endif /* THREAD_DEBUG */ mt->mt_mval = v; /* value for restarted read */ add_runq_tail(mt); /* and schedule for execution later */ } #if THREAD_DEBUG if (thread_trace) { printf("put_mvar: end\n"); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ /* return to caller */ } else { #if THREAD_DEBUG if (thread_trace) { printf("put_mvar: mvar=%p no waiters\n", mv); } #endif /* THREAD_DEBUG */ /* no threads waiting, so store the value */ mv->mv_data = v; /* return to caller */ } } return 1; } NORETURN void thread_delay(uvalue_t usecs) { #if !defined(CLOCK_INIT) ERR("thread_delay: no clock"); #else /* XXX should check if there is already a throw exn */ struct mthread *mt = remove_q_head(&runq); mt->mt_at = CLOCK_GET() + usecs; /* wakeup time */ #if THREAD_DEBUG if (thread_trace) printf("thread_delay: id=%d usecs=%ld\n", (int)mt->mt_id, (long)usecs); #endif /* THREAD_DEBUG */ /* insert in delayq which is kept sorted in time order */ struct mthread **tq; for (tq = &timeq.mq_head; *tq; tq = &(*tq)->mt_queue) { if (mt->mt_at <= (*tq)->mt_at) break; } mt->mt_queue = *tq; /* forward link */ *tq = mt; /* and put mt in place */ if (!mt->mt_queue) /* no forward link */ timeq.mq_tail = mt; resched(mt, ts_wait_time); #endif } /* Pause execution if something might still happen */ void pause_exec(void) { #if defined(CLOCK_INIT) if (timeq.mq_head) { struct mthread *mt; while (!runq.mq_head && (mt = timeq.mq_head)) { /* We are waiting for a delay to expire, so sleep a while */ CLOCK_T dly = mt->mt_at - CLOCK_GET(); if (dly > 0) { /* usleep() can be unreliable, so sleep shorter than the delay */ dly /= 4; if (dly < 50) dly = 50; CLOCK_SLEEP((useconds_t)dly); } check_timeq(); } } else { #if THREAD_DEBUG if (0) { dump_q("runq", runq); dump_q("timeq", timeq); if (0) { for(struct mvar *mv = all_mvars; mv; mv = mv->mv_next) { printf("mvar %p, data=%p\n", mv, mv->mv_data); dump_q("takeput", mv->mv_takeput); } } for(struct mthread *mt = all_threads; mt; mt = mt->mt_next) { if (mt->mt_exn->mv_data != NIL) { printf("### bad thread ThreadId#%d mask=%d state=%d\n", (int)mt->mt_id, mt->mt_mask, mt->mt_state); } } } #endif /* THREAD_DEBUG */ ERR("deadlock"); /* XXX throw async to main thread */ } #else /* CLOCK_INIT */ ERR("no clock"); #endif /* CLOCK_INIT */ } /* Interrupt a sleeping thread in a throwTo/threadDelay */ void thread_intr(struct mthread *mt) { #if THREAD_DEBUG if (thread_trace) printf("thread_intr: id=%d state=%d\n", (int)mt->mt_id, mt->mt_state); #endif /* THREAD_DEBUG */ switch(mt->mt_state) { case ts_runnable: break; /* already on runq */ case ts_wait_mvar: if (mt->mt_mask == mask_uninterruptible) /* uninterruptible */ break; /* we don't know which mvar we are waiting on, so look at all of them */ /* XXX should add a pointer in mthread to the mvar */ for (struct mvar *mv = all_mvars; mv; mv = mv->mv_next) { if (find_and_unlink(&mv->mv_takeput, mt)) goto found; if (find_and_unlink(&mv->mv_read, mt)) goto found; } ERR("thread_intr: mvar"); found: #if defined(CLOCK_INIT) mt->mt_at = -1; /* don't wait again */ #endif add_runq_tail(mt); break; case ts_wait_time: #if THREAD_DEBUG if (thread_trace) { printf("thread_intr: ts_wait_time mask=%d\n", (int)mt->mt_mask); } #endif /* THREAD_DEBUG */ if (mt->mt_mask == mask_uninterruptible) /* uninterruptible */ break; /* find thread in timeq */ if (!find_and_unlink(&timeq, mt)) ERR("thread_intr: timeq"); /* XXX should adjust mq_tail */ add_runq_tail(mt); break; case ts_finished: case ts_died: #if THREAD_DEBUG if (thread_trace) { printf("thread_intr: finished/died\n"); } #endif /* THREAD_DEBUG */ break; default: ERR("thread_intr"); } #if THREAD_DEBUG if (thread_trace) { printf("thread_intr: done\n"); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ } NORETURN void raise_exn(NODEPTR exn) { #if THREAD_DEBUG if (thread_trace) { printf("raise_exn: %p\n", exn); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ if (cur_handler) { /* Pass the exception to the handler */ cur_handler->hdl_exn = exn; longjmp(cur_handler->hdl_buf, 1); } else { /* No exception handler, jump to the scheduler */ the_exn = exn; longjmp(sched, mt_raise); } } NORETURN void raise_rts(enum rts_exn exn) { raise_exn(mkInt(exn)); } /***************** GC ******************/ /* Set FREE bit to 0 */ static INLINE void mark_used(NODEPTR n) { heapoffs_t i = LABEL(n); if (i < heap_start) return; #if SANITY if (i >= free_map_nwords * BITS_PER_WORD) ERR("mark_used"); #endif free_map[i / BITS_PER_WORD] &= ~(1ULL << (i % BITS_PER_WORD)); } /* Set FREE bit to 1, used to undo marking in GC */ static INLINE void mark_unused(NODEPTR n) { heapoffs_t i = LABEL(n); #if SANITY if (i < heap_start) ERR("Unmarking invalid heap address."); if (i >= free_map_nwords * BITS_PER_WORD) ERR("mark_used"); #endif free_map[i / BITS_PER_WORD] |= 1ULL << (i % BITS_PER_WORD); } /* Test if FREE bit is 0 */ static INLINE int is_marked_used(NODEPTR n) { heapoffs_t i = LABEL(n); if (i < heap_start) return 1; #if SANITY if (i >= free_map_nwords * BITS_PER_WORD) ERR("is_marked_used"); #endif return (free_map[i / BITS_PER_WORD] & (1ULL << (i % BITS_PER_WORD))) == 0; } static INLINE void mark_all_free(void) { memset(free_map, ~0, free_map_nwords * sizeof(bits_t)); next_scan_index = heap_start; } static INLINE NODEPTR alloc_node(enum node_tag t) { heapoffs_t i = next_scan_index / BITS_PER_WORD; int k; /* will contain bit pos + 1 */ heapoffs_t pos; NODEPTR n; heapoffs_t word; /* This can happen if we run out of memory when parsing. */ if (num_free <= 0) ERR("alloc_node"); for(;;) { word = free_map[i]; if (word) break; i++; #if SANITY if (i >= free_map_nwords) { #if 0 fprintf(stderr, "wordsize=%u, num_free=%u next_scan_index=%u i=%u free_map_nwords=%u\n", (uint)BITS_PER_WORD, (uint)num_free, (uint)next_scan_index, (uint)i, (uint)free_map_nwords); #endif ERR("alloc_node: free_map"); } #endif } k = FFS(word); pos = i * BITS_PER_WORD + k - 1; /* first free node */ n = HEAPREF(pos); // mark_used(n); // equivalent to: free_map[i] = word & (word-1); next_scan_index = pos; SETTAG(n, t); COUNT(num_alloc); num_free--; return n; } static INLINE NODEPTR new_ap(NODEPTR f, NODEPTR a) { NODEPTR n = alloc_node(T_AP); FUN(n) = f; ARG(n) = a; return n; } NODEPTR evali(NODEPTR n); /* If this is non-0 it means that the threading system is active. */ struct mthread *main_thread = 0; void start_exec(NODEPTR root) { struct mthread *mt; mt = new_thread(new_ap(root, combWorld)); /* main thread */ mt->mt_id = MAIN_THREAD; /* make it the main thread in case this is foreign export calling */ main_thread = mt; switch(setjmp(sched)) { case mt_main: break; case mt_resched: COUNT(num_resched); break; case mt_raise: /* We have an uncaught exception. * If it's the main thread, this kills the program. * Otherwise, it just kills the thread. */ if (in_raise) { ERR("FATAL: exception while trying to die"); EXIT(1); } mt = remove_q_head(&runq); if (mt->mt_id == MAIN_THREAD) { die_exn(the_exn); } else { #if THREAD_DEBUG if (thread_trace) { printf("start_exec: mt=%p id=%d died from exn\n", mt, (int)mt->mt_id); } #endif /* THREAD_DEBUG */ mt->mt_state = ts_died; mt->mt_root = NIL; } } #if THREAD_DEBUG if (thread_trace) { printf("start_exec:\n"); dump_q("runq", runq); } #endif /* THREAD_DEBUG */ for(;;) { if (!runq.mq_head) pause_exec(); mt = runq.mq_head; /* front thread */ if (!mt) /* this should never happen */ ERR("no threads"); glob_slice = mt->mt_slice + slice; #if THREAD_DEBUG if (thread_trace) printf("start_exec: start %d, slice=%d\n", (int)mt->mt_id, (int)glob_slice); #endif /* THREAD_DEBUG */ num_reductions += glob_slice-1; (void)evali(mt->mt_root); /* run it */ num_reductions -= glob_slice; /* when evali() returns the thread is done */ (void)remove_q_head(&runq); /* remove front thread */ #if THREAD_DEBUG if (thread_trace) { printf("start_exec: mt=%p id=%d finished\n", mt, (int)mt->mt_id); } #endif /* THREAD_DEBUG */ mt->mt_state = ts_finished; mt->mt_root = NIL; /* XXX mt_mval, mt_thrown */ if (mt->mt_id == MAIN_THREAD) { main_thread = 0; #if THREAD_DEBUG if (thread_trace) { printf("start_exec: main thread done\n"); } #endif /* THREAD_DEBUG */ return; /* when the main thread dies it's all over */ } } } /* One node of each kind for primitives, these are never GCd. */ /* We use linear search in this, because almost all lookups * are among the combinators. */ static const struct { const char *name; const enum node_tag tag; const enum node_tag flipped; /* What should (C op) reduce to? defaults to T_FREE */ // NODEPTR node; } primops[] = { /* combinators */ /* sorted by frequency in a typical program */ { "B", T_B }, { "O", T_O }, { "K", T_K, T_A }, { "C'", T_CC }, { "C", T_C }, { "A", T_A, T_K }, { "S'", T_SS }, { "P", T_P }, { "R", T_R }, { "I", T_I }, { "S", T_S }, { "U", T_U }, { "Y", T_Y }, { "B'", T_BB }, { "Z", T_Z }, /* { "J", T_J },*/ { "K2", T_K2 }, { "K3", T_K3 }, { "K4", T_K4 }, { "C'B", T_CCB }, /* primops */ { "+", T_ADD, T_ADD }, { "-", T_SUB, T_SUBR }, { "*", T_MUL, T_MUL }, { "quot", T_QUOT }, { "rem", T_REM }, { "uquot", T_UQUOT }, { "urem", T_UREM }, { "subtract", T_SUBR, T_SUB }, { "neg", T_NEG }, { "and", T_AND, T_AND }, { "or", T_OR, T_OR }, { "xor", T_XOR, T_XOR }, { "inv", T_INV }, { "shl", T_SHL }, { "shr", T_SHR }, { "ashr", T_ASHR }, { "popcount", T_POPCOUNT }, { "clz", T_CLZ }, { "ctz", T_CTZ }, #if WANT_FLOAT64 { "d+" , T_DADD, T_DADD}, { "d-" , T_DSUB }, { "d*" , T_DMUL, T_DMUL}, { "d/", T_DDIV}, { "dneg", T_DNEG}, { "itod", T_ITOD}, { "Itod", T_I64TOD}, { "d==", T_DEQ, T_DEQ}, { "d/=", T_DNE, T_DNE}, { "d<", T_DLT, T_DGT}, { "d<=", T_DLE, T_DGE}, { "d>", T_DGT, T_DLT}, { "d>=", T_DGE, T_DLE}, #endif /* WANT_FLOAT64 */ #if WANT_FLOAT32 { "f+" , T_FADD, T_FADD}, { "f-" , T_FSUB }, { "f*" , T_FMUL, T_FMUL}, { "f/", T_FDIV}, { "fneg", T_FNEG}, { "Itof", T_I64TOF}, { "itof", T_ITOF}, { "f==", T_FEQ, T_FEQ}, { "f/=", T_FNE, T_FNE}, { "f<", T_FLT, T_FGT}, { "f<=", T_FLE, T_FGE}, { "f>", T_FGT, T_FLT}, { "f>=", T_FGE, T_FLE}, #endif /* WANT_FLOAT32 */ { "bs++", T_BSAPPEND }, { "bs++.", T_BSAPPENDDOT }, { "bs==", T_BSEQ, T_BSEQ }, { "bs/=", T_BSNE, T_BSNE }, { "bs<", T_BSLT, T_BSGT }, { "bs<=", T_BSLE, T_BSGE }, { "bs>", T_BSGT, T_BSLT }, { "bs>=", T_BSGE, T_BSLE }, { "bscmp", T_BSCMP }, { "bspack", T_BSPACK }, { "bsunpack", T_BSUNPACK }, { "bsreplicate", T_BSREPLICATE }, { "bslength", T_BSLENGTH }, { "bssubstr", T_BSSUBSTR }, { "bsindex", T_BSINDEX }, { "bswrite", T_BSWRITE }, { "ord", T_I }, { "chr", T_I }, { "==", T_EQ, T_EQ }, { "/=", T_NE, T_NE }, { "<", T_LT, T_GT }, { "u<", T_ULT, T_UGT }, { "u<=", T_ULE, T_UGE }, { "u>", T_UGT, T_ULT }, { "u>=", T_UGE, T_ULE }, { "<=", T_LE, T_GE }, { ">", T_GT, T_LT }, { ">=", T_GE, T_LE }, { "fp+", T_FPADD }, { "fp2p", T_FP2P }, { "fpnew", T_FPNEW }, { "fpfin", T_FPFIN }, // { "fpstr", T_FPSTR }, { "fp2bs", T_FP2BS }, { "bs2fp", T_BS2FP }, { "seq", T_SEQ }, { "icmp", T_ICMP }, { "ucmp", T_UCMP }, { "rnf", T_RNF }, { "fromUTF8", T_BSFROMUTF8 }, { "toUTF8", T_BSTOUTF8 }, { "headUTF8", T_BSHEADUTF8 }, { "tailUTF8", T_BSTAILUTF8 }, /* IO primops */ { "IO.>>=", T_IO_BIND }, { "IO.>>", T_IO_THEN }, { "IO.return", T_IO_RETURN }, { "IO.serialize", T_IO_SERIALIZE }, { "IO.print", T_IO_PRINT }, { "IO.deserialize", T_IO_DESERIALIZE }, { "IO.stdin", T_IO_STDIN }, { "IO.stdout", T_IO_STDOUT }, { "IO.stderr", T_IO_STDERR }, { "IO.getArgRef", T_IO_GETARGREF }, { "IO.performIO", T_IO_PERFORMIO }, { "IO.gc", T_IO_GC }, { "IO.stats", T_IO_STATS }, { "IO.pp", T_IO_PP }, { "raise", T_RAISE }, { "catch", T_CATCH }, { "catchr", T_CATCHR }, { "A.alloc", T_ARR_ALLOC }, { "A.copy", T_ARR_COPY }, { "A.size", T_ARR_SIZE }, { "A.read", T_ARR_READ }, { "A.write", T_ARR_WRITE }, { "A.trunc", T_ARR_TRUNC }, { "A.==", T_ARR_EQ }, { "dynsym", T_DYNSYM }, { "IO.fork", T_IO_FORK }, { "IO.thid", T_IO_THID }, { "thnum", T_THNUM }, { "IO.throwto", T_IO_THROWTO }, { "IO.yield", T_IO_YIELD }, { "IO.newmvar", T_IO_NEWMVAR }, { "IO.takemvar", T_IO_TAKEMVAR }, { "IO.putmvar", T_IO_PUTMVAR }, { "IO.readmvar", T_IO_READMVAR }, { "IO.trytakemvar", T_IO_TRYTAKEMVAR }, { "IO.tryputmvar", T_IO_TRYPUTMVAR }, { "IO.tryreadmvar", T_IO_TRYREADMVAR }, { "IO.threaddelay", T_IO_THREADDELAY }, { "IO.threadstatus", T_IO_THREADSTATUS }, { "IO.getmaskingstate", T_IO_GETMASKINGSTATE }, { "IO.setmaskingstate", T_IO_SETMASKINGSTATE }, { "newCAStringLen", T_NEWCASTRINGLEN }, { "packCString", T_PACKCSTRING }, { "packCStringLen", T_PACKCSTRINGLEN }, { "bsgrab", T_BSGRAB }, { "toPtr", T_TOPTR }, { "toInt", T_TOINT }, { "toDbl", T_TODBL }, { "toFlt", T_TOFLT }, { "fromDbl", T_FROMDBL }, { "fromFlt", T_FROMFLT }, { "toFunPtr", T_TOFUNPTR }, { "IO.ccall", T_IO_CCALL }, { "isint", T_ISINT }, { "SPnew", T_SPNEW }, { "SPderef", T_SPDEREF }, { "SPfree", T_SPFREE }, { "Wknew", T_WKNEW }, { "Wknewfin", T_WKNEWFIN }, { "Wkderef", T_WKDEREF }, { "Wkfinal", T_WKFINAL }, { "binint2", T_BININT2 }, { "binint1", T_BININT1 }, { "bindbl2", T_BINDBL2 }, { "bindbl1", T_BINDBL1 }, { "binbs2", T_BINBS2 }, { "binbs1", T_BINBS1 }, { "unint1", T_UNINT1 }, { "undbl1", T_UNDBL1 }, #if WANT_INT64 #if !NEED_INT64 { "I+", T_ADD, T_ADD }, { "I-", T_SUB, T_SUBR }, { "I*", T_MUL, T_MUL }, { "Iquot", T_QUOT }, { "Irem", T_REM }, { "Iuquot", T_UQUOT }, { "Iurem", T_UREM }, { "Isubtract", T_SUBR, T_SUB }, { "Ineg", T_NEG }, { "Iand", T_AND, T_AND }, { "Ior", T_OR, T_OR }, { "Ixor", T_XOR, T_XOR }, { "Iinv", T_INV }, { "Ishl", T_SHL }, { "Ishr", T_SHR }, { "Iashr", T_ASHR }, { "Ipopcount", T_POPCOUNT }, { "Iclz", T_CLZ }, { "Ictz", T_CTZ }, { "I==", T_EQ, T_EQ }, { "I/=", T_NE, T_NE }, { "I<", T_LT, T_GT }, { "Iu<", T_ULT, T_UGT }, { "Iu<=", T_ULE, T_UGE }, { "Iu>", T_UGT, T_ULT }, { "Iu>=", T_UGE, T_ULE }, { "I<=", T_LE, T_GE }, { "I>", T_GT, T_LT }, { "I>=", T_GE, T_LE }, { "Iicmp", T_ICMP }, { "Iucmp", T_UCMP }, { "Itoi", T_I }, { "itoI", T_I }, { "Utou", T_I }, { "utoU", T_I }, #else /* WORD_SIZE == 64 */ /* WORD_SIZE == 32 */ { "I+", T_ADD64, T_ADD64 }, { "I-", T_SUB64, T_SUBR64 }, { "I*", T_MUL64, T_MUL64 }, { "Iquot", T_QUOT64 }, { "Irem", T_REM64 }, { "Iuquot", T_UQUOT64 }, { "Iurem", T_UREM64 }, { "Isubtract", T_SUBR64, T_SUB64 }, { "Ineg", T_NEG64 }, { "Iand", T_AND64, T_AND64 }, { "Ior", T_OR64, T_OR64 }, { "Ixor", T_XOR64, T_XOR64 }, { "Iinv", T_INV64 }, { "Ishl", T_SHL64 }, { "Ishr", T_SHR64 }, { "Iashr", T_ASHR64 }, { "Ipopcount", T_POPCOUNT64 }, { "Iclz", T_CLZ64 }, { "Ictz", T_CTZ64 }, { "I==", T_EQ64, T_EQ64 }, { "I/=", T_NE64, T_NE64 }, { "I<", T_LT64, T_GT64 }, { "Iu<", T_ULT64, T_UGT64 }, { "Iu<=", T_ULE64, T_UGE64 }, { "Iu>", T_UGT64, T_ULT64 }, { "Iu>=", T_UGE64, T_ULE64 }, { "I<=", T_LE64, T_GE64 }, { "I>", T_GT64, T_LT64 }, { "I>=", T_GE64, T_LE64 }, { "Iicmp", T_ICMP64 }, { "Iucmp", T_UCMP64 }, { "itoI", T_ITOI64 }, { "Itoi", T_I64TOI }, { "utoU", T_UTOU64 }, { "Utou", T_U64TOU }, #endif /* WORD_SIZE == 64 */ #endif /* WANT_INT64 */ }; #if GCRED enum node_tag flip_ops[T_LAST_TAG+1]; #endif #if WANT_STDIO /* Create a dummy foreign pointer for the standard stdio handles. */ /* These handles are never gc():d. */ void mk_std(NODEPTR n, FILE *f) { struct final *fin = mcalloc(1, sizeof(struct final)); struct forptr *fp = mcalloc(1, sizeof(struct forptr)); BFILE *bf = add_utf8(add_FILE(f)); SETTAG(n, T_FORPTR); FORPTR(n) = fp; fin->arg = bf; fin->back = fp; fp->payload.string = bf; fp->finalizer = fin; } #endif void init_nodes(void) { enum node_tag t; size_t j; NODEPTR n; ALLOC_HEAP(heap_size); free_map_nwords = (heap_size + BITS_PER_WORD - 1) / BITS_PER_WORD; /* bytes needed for free map */ free_map = mmalloc(free_map_nwords * sizeof(bits_t)); /* Set up permanent nodes */ heap_start = 0; for(t = T_FREE; t <= T_LAST_TAG; t++) { NODEPTR n = HEAPREF(heap_start++); SETTAG(n, t); switch (t) { case T_K: combK = n; break; case T_A: combTrue = n; break; case T_I: combI = n; break; case T_O: combCons = n; break; case T_P: combPair = n; break; case T_CC: combCC = n; break; case T_BB: combBB = n; break; case T_B: combB = n; break; case T_C: combC = n; break; case T_Z: combZ = n; break; case T_U: combU = n; break; case T_K2: combK2 = n; break; case T_K3: combK3 = n; break; case T_IO_BIND: combIOBIND = n; break; case T_IO_THEN: combIOTHEN = n; break; case T_IO_RETURN: combIORETURN = n; break; case T_IO_SETMASKINGSTATE: combSETMASKINGSTATE = n; break; case T_IO_PERFORMIO: combPERFORMIO = n; break; case T_BININT1: combBININT1 = n; break; case T_BININT2: combBININT2 = n; break; case T_UNINT1: combUNINT1 = n; break; case T_BININT64_1: combBININT64_1 = n; break; case T_BININT64_2: combBININT64_2 = n; break; case T_UNINT64_1: combUNINT64_1 = n; break; case T_BINDBL1: combBINDBL1 = n; break; case T_BINDBL2: combBINDBL2 = n; break; case T_UNDBL1: combUNDBL1 = n; break; case T_BINFLT1: combBINFLT1 = n; break; case T_BINFLT2: combBINFLT2 = n; break; case T_UNFLT1: combUNFLT1 = n; break; case T_BINBS1: combBINBS1 = n; break; case T_BINBS2: combBINBS2 = n; break; case T_IO_THROWTO: combTHROWTO = n; break; case T_CATCHR: combCATCHR = n; break; #if WANT_STDIO case T_IO_STDIN: comb_stdin = n; mk_std(n, stdin); break; case T_IO_STDOUT: comb_stdout = n; mk_std(n, stdout); break; case T_IO_STDERR: comb_stderr = n; mk_std(n, stderr); break; #endif default: break; } for (j = sizeof primops / sizeof primops[0]; j-- > 0; ) { // if (primops[j].tag == t) { // primops[j].node = n; // } #if WANT_TAGNAMES tag_names[primops[j].tag] = primops[j].name; #endif } } #if GCRED for (j = 0; j < sizeof primops / sizeof primops[0]; j++) { flip_ops[primops[j].tag] = primops[j].flipped; } #endif /* The representation of the constructors of * data Ordering = LT | EQ | GT * do not have single constructors. * But we can make compound one, since they are irreducible. */ #define NEWAP(c, f, a) do { n = HEAPREF(heap_start++); SETTAG(n, T_AP); FUN(n) = (f); ARG(n) = (a); (c) = n;} while(0) #define MKINT(c, i) do { n = HEAPREF(heap_start++); SETTAG(n, T_INT); SETVALUE(n, i); (c) = n; } while(0) NEWAP(combLT, combZ, combFalse); /* Z K */ NEWAP(combEQ, combFalse, combFalse); /* K K */ NEWAP(combGT, combFalse, combTrue); /* K A */ { /* The displaySomeException compiles to (U (U (K2 A))) */ NODEPTR x; NEWAP(x, combK2, combTrue); /* (K2 A) */ NEWAP(x, combU, x); /* (U (K2 A)) */ NEWAP(combShowExn, combU, x); /* (U (U (K2 A))) */ } NEWAP(combJust, combZ, combU); /* (Z U) */ MKINT(combWorld, 99999); NEWAP(combPairUnit, combPair, combUnit); #undef NEWAP #if INTTABLE /* Allocate permanent Int nodes */ for (int i = LOW_INT; i < HIGH_INT; i++) { NODEPTR n = HEAPREF(heap_start++); intTable[i - LOW_INT] = n; SETTAG(n, T_INT); SETVALUE(n, i); } #endif /* Round up heap_start to the next bitword boundary to avoid the permanent nodes. */ heap_start = (heap_start + BITS_PER_WORD - 1) / BITS_PER_WORD * BITS_PER_WORD; mark_all_free(); num_free = heap_size - heap_start; } #if GCRED counter_t red_a, red_k, red_i, red_int, red_flip, red_bi, red_bxi, red_ccbi, red_cc, red_cci, red_ccbbcp; #endif counter_t red_bb, red_k4, red_k3, red_k2, red_ccb, red_z, red_r; //counter_t mark_depth; //counter_t max_mark_depth = 0; void mark(NODEPTR *np); void mark_mvar(struct mvar *mv); void mark_thread(struct mthread *mt); /* Follow indirections */ static INLINE NODEPTR indir(NODEPTR *np) { NODEPTR n = *np; while (GETTAG(n) == T_IND) n = GETINDIR(n); *np = n; return n; } /***** weak pointers *****/ struct weak_ptr { struct weak_ptr *next; /* list of all weak pointers. */ int marked; /* seen by GC */ NODEPTR key; /* key, this is the weak pointer */ NODEPTR value; /* associated value */ NODEPTR finalize; /* maybe finalizer */ }; struct weak_ptr *allweaks; /* head of all weak pointers */ /* After GC mark phase, deal with weak pointers */ void sweep_weaks(void) { restart: /* all weak pointer records are alive, marked or not */ for (struct weak_ptr *wp = allweaks; wp; wp = wp->next) { if (!wp->value) continue; /* the weak pointer is already dead */ (void)indir(&wp->key); if (is_marked_used(wp->key)) { /* The key is used, so mark the other parts */ if (!is_marked_used(wp->value) || (wp->finalize != 0 && !is_marked_used(wp->finalize))) { /* Not already marked */ mark(&wp->value); if (wp->finalize) mark(&wp->finalize); /* This marking might have marked other keys, so restart the scan */ goto restart; } } else { /* The key is not marked, so the weak reference is dead */ wp->value = 0; } } /* Create finalizers for all weak pointers that just died */ for (struct weak_ptr *wp = allweaks; wp; wp = wp->next) { if (!wp->value && wp->finalize) { struct mthread *mt = new_thread(wp->finalize); mark_thread(mt); /* mark it, since overall thread marking has already run */ wp->finalize = 0; wp->key = 0; /* not needed, but for sanity */ /* Marking the finalizer does not resurrect keys */ } } /* If a weak pointer object is unreferenced and it has been finalized, * then it can be garbage collected. */ for (struct weak_ptr **wpp = &allweaks; *wpp; ) { struct weak_ptr *wp = *wpp; if (!wp->marked && !wp->value) { /* not marked, so unlink and free */ *wpp = wp->next; COUNT(num_gc_weak); free(wp); } else { /* point to the next weak_ptr */ wpp = &wp->next; } } } NODEPTR new_weak_ptr(NODEPTR key, NODEPTR value, NODEPTR finalize) { struct weak_ptr *wp = mmalloc(sizeof(struct weak_ptr)); wp->next = allweaks; allweaks = wp; wp->marked = 0; wp->key = key; wp->value = value; if (finalize) { wp->finalize = new_ap(finalize, combWorld); } else { wp->finalize = 0; } COUNT(num_new_weak); NODEPTR n = alloc_node(T_WEAK); WEAK(n) = wp; return n; } NODEPTR deref_weak_ptr(struct weak_ptr *wp) { if (!wp->value) return combNothing; return new_ap(combJust, wp->value); } void finalize_weak_ptr(struct weak_ptr *wp) { NODEPTR final = wp->finalize; if (!final) return; wp->finalize = 0; (void)evali(final); } /**********************************************************/ /* Throwing, e.g., a UserInterrupt exception, to the main thread * can happen from any thread (the one that happens to poll). * Throwing an exception can block, so we can't throw it from * the current thread. Instead, we spawn a new thread, whose * only job it is to throw the exception. */ void async_throwto(struct mthread *mt, NODEPTR exn) { GCCHECK(4); NODEPTR thid = alloc_node(T_THID); THR(thid) = mt; NODEPTR root = new_ap(new_ap(new_ap(combTHROWTO, thid), exn), combWorld); (void)new_thread(root); /* spawn and put on runq */ } void mark_thread(struct mthread *mt) { if (mt->mt_mark) return; /* already marked */ mt->mt_mark = true; if (mt->mt_root != NIL) mark(&mt->mt_root); mark_mvar(mt->mt_exn); if (mt->mt_mval != NIL) mark(&mt->mt_mval); } void mark_mvar(struct mvar *mv) { if (mv->mv_mark) return; mv->mv_mark = true; if (mv->mv_data != NIL) mark(&mv->mv_data); for (struct mthread *mt = mv->mv_takeput.mq_head; mt; mt = mt->mt_next) mark_thread(mt); for (struct mthread *mt = mv->mv_read.mq_head; mt; mt = mt->mt_next) mark_thread(mt); } /* * Only allow GC reductions when the node is not near the top of the stack. * The reason is that when GC is triggered we are just starting a reduction * and the combinator at the left-bottom of the spine is being reduced. * If a GC reduction removes this combinator, then bad things happen. */ static int gc_red_ok(NODEPTR n) { for (stackptr_t s = stack_ptr; s >= 0 && s >= stack_ptr - 5; s--) if (n == stack[s]) return 0; return 1; } /* Mark all used nodes reachable from *np, updating *np. */ void mark(NODEPTR *np) { stackptr_t stk = stack_ptr; NODEPTR n; NODEPTR *to_push = 0; /* silence warning by initializing */ #if GCRED value_t val; #endif enum node_tag tag; // mark_depth++; // if (mark_depth % 10000 == 0) // PRINT("mark depth %"PRIcounter"\n", mark_depth); top: n = *np; tag = GETTAG(n); if (tag == T_IND) { #if SANITY int loop = 0; /* Skip indirections, and redirect start pointer */ while ((tag = GETTAG(n)) == T_IND) { // PRINT("*"); fflush(stdout); n = GETINDIR(n); if (loop++ > 10000000) { //PRINT("%p %p %p\n", n, GETINDIR(n), GETINDIR(GETINDIR(n))); ERR("IND loop"); } } // if (loop) // PRINT("\n"); #else /* SANITY */ while ((tag = GETTAG(n)) == T_IND) { n = GETINDIR(n); } #endif /* SANITY */ *np = n; } if (n < cells || n > cells + heap_size) ERR("bad n"); if (is_marked_used(n)) { goto fin; } num_marked++; mark_used(n); switch (tag) { #if GCRED #define GCREDIND(x) do { NODEPTR nn = (x); mark(&nn); SETINDIR(n, nn); goto fin; } while(0) case T_INT: #if INTTABLE if (LOW_INT <= (val = GETVALUE(n)) && val < HIGH_INT) { SETINDIR(n, intTable[val - LOW_INT]); COUNT(red_int); goto top; } goto fin; #endif /* INTTABLE */ case T_AP: if (want_gc_red) { NODEPTR fun = indir(&FUN(n)); NODEPTR arg = indir(&ARG(n)); enum node_tag funt = GETTAG(fun); enum node_tag argt = GETTAG(arg); enum node_tag funfunt = funt == T_AP ? GETTAG(indir(&FUN(fun))) : T_FREE; enum node_tag funargt = argt == T_AP ? GETTAG(indir(&FUN(arg))) : T_FREE; /* This is really only fruitful just after parsing. It can be removed. */ if (funfunt == T_A && gc_red_ok(n)) { /* Do the A x y --> y reduction */ NODEPTR y = ARG(n); COUNT(red_a); GCREDIND(y); } if (funfunt == T_K && gc_red_ok(n)) { /* Do the K x y --> x reduction */ NODEPTR x = ARG(FUN(n)); COUNT(red_k); GCREDIND(x); } if (funt == T_I && gc_red_ok(n)) { /* Do the I x --> x reduction */ NODEPTR x = ARG(n); COUNT(red_i); GCREDIND(x); } if(funt == T_CC && argt == T_I && gc_red_ok(n)) { /* C' I --> C */ SETTAG(n, T_C); COUNT(red_cci); goto top; } if(funt == T_CCB && argt == T_AP) { NODEPTR funarg = indir(&FUN(arg)); NODEPTR argarg = indir(&ARG(arg)); if (GETTAG(argarg) == T_P && GETTAG(funarg) == T_AP) { if (GETTAG(indir(&FUN(funarg))) == T_B && GETTAG(indir(&ARG(funarg))) == T_C && gc_red_ok(n)) { /* C'B ((B C) P) --> C */ SETTAG(n, T_C); COUNT(red_ccbbcp); goto top; } } } if(funt == T_B && argt == T_I && gc_red_ok(n)) { /* B I --> I */ SETTAG(n, T_I); COUNT(red_bi); goto top; } if(funfunt == T_B && argt == T_I && gc_red_ok(n)) { /* B x I --> x */ NODEPTR x = ARG(FUN(n)); COUNT(red_bxi); GCREDIND(x); } if(funfunt == T_CCB && argt == T_I && gc_red_ok(n)) { /* C'B x I --> x */ NODEPTR x = ARG(FUN(n)); COUNT(red_ccbi); GCREDIND(x); } if(funt == T_C && funargt == T_C && gc_red_ok(n)) { /* C (C x) --> x */ NODEPTR x = ARG(ARG(n)); COUNT(red_cc); GCREDIND(x); } #if 0 /* Very rare */ if (funt == T_S && funargt == T_K && gc_red_ok(n)) { /* S (K x) --> B x */ printf("SK"); fflush(stdout); } #endif #if 0 /* Fairly frequent, but needs allocation */ if (funfunt == T_B && funargt == T_K) { /* B x (K y) --> K x y */ printf("BxK\n"); } #endif #if 1 if (funt == T_C && gc_red_ok(n)) { enum node_tag tf; if ((tf = flip_ops[argt])) { /* Do the C op --> flip_op reduction */ // PRINT("%s -> %s\n", tag_names[tt], tag_names[tf]); COUNT(red_flip); GCREDIND(HEAPREF(tf)); } } #endif } #else /* GCRED */ case T_AP: #endif /* GCRED */ /* Avoid tail recursion */ np = &FUN(n); to_push = &ARG(n); break; case T_ARR: { struct ioarray *arr = ARR(n); // arr->marked records marking progress through arr. if (arr->marked >= arr->size) { goto fin; } // We unmark the array as a whole and push it as long // as there's more entries to scan. mark_unused(n); num_marked--; to_push = np; np = &arr->array[arr->marked++]; break; } case T_FORPTR: FORPTR(n)->finalizer->marked = 1; goto fin; case T_THID: mark_thread(THR(n)); goto fin; case T_MVAR: mark_mvar(MVAR(n)); goto fin; case T_WEAK: WEAK(n)->marked = 1; goto fin; default: goto fin; } if (!is_marked_used(*to_push)) { // mark_depth++; PUSH((NODEPTR)to_push); } goto top; fin: // if (mark_depth > max_mark_depth) { // max_mark_depth = mark_depth; // } // mark_depth--; if (stack_ptr > stk) { np = (NODEPTR *)POPTOP(); goto top; } return; } // stackptr_t gc_tot; /* Perform a garbage collection: - Mark nodes from the stack - Mark permanent arrays - Mark threads that have a root - Scan and free arrays - Scan and free foreign pointers and run finalizers - Scan and free threads - Scan and free mvars */ void gc(void) { stackptr_t i; //printf("****** GC ********\n"); // gc_tot += stack_ptr+1; num_gc++; num_marked = 0; #if WANT_STDIO if (verbose > 1) PRINT("gc mark\n"); #endif gc_mark_time -= GETTIMEMILLI(); mark_all_free(); /* Mark everything reachable from the stack */ for (i = 0; i <= stack_ptr; i++) mark(&stack[i]); /* Mark everything reachable from permanent array nodes */ for (struct ioarray *arr = array_root; arr; arr = arr->next) { if (arr->permanent) { for (i = 0; i < arr->size; i++) mark(&arr->array[i]); } } /* Mark all FFI exports */ if (xffe_table) { for(struct ffe_entry *f = xffe_table; f->ffe_name; f++) { mark((NODEPTR*)&f->ffe_value); } } /* Mark used stable pointers */ for (size_t i = 0; i < sp_capacity; i++) { if (sp_table[i] != NIL) mark(&sp_table[i]); } /* Mark everything reachable from the threads. * Note, zombie threads have no root so they are not marked. */ for (struct mthread *mt = all_threads; mt; mt = mt->mt_next) { if (mt->mt_root != NIL) mark_thread(mt); } /* check for unmarked weak pointers */ sweep_weaks(); gc_mark_time += GETTIMEMILLI(); if (num_marked > max_num_marked) max_num_marked = num_marked; num_free = heap_size - heap_start - num_marked; if (num_free < heap_size / 50) ERR("heap exhausted"); gc_scan_time -= GETTIMEMILLI(); /* Free unused arrays */ for (struct ioarray **arrp = &array_root; *arrp; ) { struct ioarray *arr = *arrp; if (arr->marked || arr->permanent) { arr->marked = 0; arrp = &arr->next; } else { *arrp = arr->next; /* unlink */ num_arr_free++; FREE(arr); /* and FREE */ } } /* Run finalizers on unused foreign pointers. */ for (struct final **finp = &final_root; *finp; ) { struct final *fin = *finp; if (fin->marked) { fin->marked = 0; finp = &fin->next; } else { /* Unused, run finalizer and free all associated memory */ if (fin->size == NOSIZE) { num_fin_free++; } else { num_bs_free++; num_bs_inuse -= fin->size; if (num_bs_alloc - num_bs_free > num_bs_alloc_max) num_bs_alloc_max = num_bs_alloc - num_bs_free; } void (*f)(void *) = (void (*)(void *))fin->final; //printf("forptr free fin=%p, f=%p", fin, f); //fflush(stdout); if (f) { //printf("finalizer fin=%p final=%p\n", fin, f); (*f)(fin->arg); } for (struct forptr *p = fin->back; p; ) { struct forptr *q = p->next; //printf("free fp=%p\n", p); //printf(" p=%p desc=%s", p, p->desc ? p->desc : "NONE"); //fflush(stdout); FREE(p); //memset(p, 0x55, sizeof *p); p = q; } //printf("\n"); *finp = fin->next; //printf("free fin=%p\n", fin); FREE(fin); //memset(fin, 0x77, sizeof *fin); } } /* Remove unreferenced zombie threads */ for (struct mthread **mtp = &all_threads; *mtp; ) { struct mthread *mt = *mtp; if ((mt->mt_state == ts_died || mt->mt_state == ts_finished) && !mt->mt_mark) { COUNT(num_thread_reap); *mtp = mt->mt_next; free(mt); } else { mt->mt_mark = false; mtp = &mt->mt_next; } } /* Remove unreferences mvars */ for (struct mvar **mvp = &all_mvars; *mvp; ) { struct mvar *mv = *mvp; if (!mv->mv_mark) { COUNT(num_mvar_free); *mvp = mv->mv_next; free(mv); } else { mv->mv_mark = false; mvp = &mv->mv_next; } } gc_scan_time += GETTIMEMILLI(); #if WANT_STDIO if (verbose > 1) { PRINT("gc done, %"PRIcounter" free\n", num_free); /*PRINT(" GC reductions A=%"PRIcounter", K=%"PRIcounter", I=%"PRIcounter", int=%"PRIcounter" flip=%"PRIcounter"\n", red_a, red_k, red_i, red_int, red_flip);*/ } if (gcbell) { fputc('\007', stderr); /* ring the bell */ fflush(stderr); } #endif /* !WANT_STDIO */ #if 0 /* For debugging only: mark all free cells */ for(int n = 0; n < heap_size; n++) { NODEPTR p = HEAPREF(n); if (!is_marked_used(p)) { SETTAG(p, T_FREE); } } #endif #if 0 { BFILE *err = add_fd(2); putsb("GC ", err); putdecb(num_free, err); putsb(" free\r\n", err); closeb(err); } #endif } static INLINE value_t peekWord(value_t *p) { return *p; } static INLINE void pokeWord(value_t *p, value_t w) { *p = w; } static INLINE void * peekPtr(void **p) { return *p; } static INLINE void pokePtr(void **p, void *w) { *p = w; } static INLINE uvalue_t peek_uint8(uint8_t *p) { return *p; } static INLINE void poke_uint8(uint8_t *p, value_t w) { *p = (uint8_t)w; } static INLINE uvalue_t peek_uint16(uint16_t *p) { return *p; } static INLINE void poke_uint16(uint16_t *p, value_t w) { *p = (uint16_t)w; } #if WORD_SIZE >= 32 static INLINE uvalue_t peek_uint32(uint32_t *p) { return *p; } static INLINE void poke_uint32(uint32_t *p, value_t w) { *p = (uint32_t)w; } #endif /* WORD_SIZE >= 32 */ #if WORD_SIZE >= 64 static INLINE uvalue_t peek_uint64(uint64_t *p) { return *p; } static INLINE void poke_uint64(uint64_t *p, value_t w) { *p = (uint64_t)w; } #endif /* WORD_SIZE >= 64 */ static INLINE value_t peek_int8(int8_t *p) { return *p; } static INLINE void poke_int8(int8_t *p, value_t w) { *p = (int8_t)w; } static INLINE value_t peek_int16(int16_t *p) { return *p; } static INLINE void poke_int16(int16_t *p, value_t w) { *p = (int16_t)w; } #if WORD_SIZE >= 32 static INLINE value_t peek_int32(int32_t *p) { return *p; } static INLINE void poke_int32(int32_t *p, value_t w) { *p = (int32_t)w; } #endif /* WORD_SIZE >= 32 */ #if WORD_SIZE >= 64 static INLINE value_t peek_int64(int64_t *p) { return *p; } static INLINE void poke_int64(int64_t *p, value_t w) { *p = (int64_t)w; } #endif /* WORD_SIZE >= 64 */ static INLINE value_t peek_int(int *p) { return *p; } static INLINE void poke_int(int *p, value_t w) { *p = (int)w; } static INLINE value_t peek_uint(unsigned int *p) { return *p; } static INLINE void poke_uint(unsigned int *p, value_t w) { *p = (unsigned int)w; } static INLINE value_t peek_char(char *p) { return *p; } static INLINE void poke_char(char *p, value_t w) { *p = (char)w; } static INLINE value_t peek_schar(signed char *p) { return *p; } static INLINE void poke_schar(signed char *p, value_t w) { *p = (signed char)w; } static INLINE value_t peek_uchar(unsigned char *p) { return *p; } static INLINE void poke_uchar(unsigned char *p, value_t w) { *p = (unsigned char)w; } static INLINE value_t peek_short(short *p) { return *p; } static INLINE void poke_short(short *p, value_t w) { *p = (short)w; } static INLINE value_t peek_ushort(unsigned short *p) { return *p; } static INLINE void poke_ushort(unsigned short *p, value_t w) { *p = (unsigned short)w; } static INLINE value_t peek_long(long *p) { return *p; } static INLINE void poke_long(long *p, value_t w) { *p = (long)w; } static INLINE value_t peek_ulong(unsigned long *p) { return *p; } static INLINE void poke_ulong(unsigned long *p, value_t w) { *p = (unsigned long)w; } static INLINE value_t peek_llong(long long *p) { return *p; } static INLINE void poke_llong(long long *p, value_t w) { *p = (long long)w; } static INLINE value_t peek_ullong(unsigned long long *p) { return *p; } static INLINE void poke_ullong(unsigned long long *p, value_t w) { *p = (unsigned long long)w; } static INLINE value_t peek_size_t(size_t *p) { return *p; } static INLINE void poke_size_t(size_t *p, value_t w) { *p = (size_t)w; } #if WANT_FLOAT32 static INLINE flt32_t peek_flt32(flt32_t *p) { return *p; } static INLINE void poke_flt32(flt32_t *p, flt32_t w) { *p = w; } #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 static INLINE flt64_t peek_flt64(flt64_t *p) { return *p; } static INLINE void poke_flt64(flt64_t *p, flt64_t w) { *p = w; } #endif /* WANT_FLOAT64 */ /* Look up an FFI function by name */ value_t lookupFFIname(const char *name) { size_t i; for(i = 0; ffi_table[i].ffi_name; i++) if (strcmp(ffi_table[i].ffi_name, name) == 0) return (value_t)i; if (xffi_table) { for(i = 0; xffi_table[i].ffi_name; i++) if (strcmp(xffi_table[i].ffi_name, name) == 0) return (value_t)(i + num_ffi); } return -1; } NODEPTR ffiNode(const char *buf) { NODEPTR r; value_t i = lookupFFIname(buf); char *fun; if (i < 0) { /* lookup failed, generate a node that will dynamically generate an error */ r = alloc_node(T_BADDYN); fun = mmalloc(strlen(buf) + 1); strcpy(fun, buf); CSTR(r) = fun; } else { r = alloc_node(T_IO_CCALL); SETVALUE(r, i); } return r; } /* If the next input character is c, then consume it, else leave it alone. */ int gobble(BFILE *f, int c) { int d = getb(f); if (c == d) { return 1; } else { ungetb(d, f); return 0; } } /* Get a non-terminating character. ' ' and '\n' terminates a token. */ int getNT(BFILE *f) { int c; c = getb(f); if (c == ' ' || c == '\n') { return 0; } else { return c; } } value_t parse_int(BFILE *f) { // Parse using uvalue_t, which wraps on overflow. uvalue_t i = 0; uvalue_t neg = 1; int c = getb(f); if (c == '-') { neg = -1; c = getb(f); } for(;;) { i = i * 10 + (c - '0'); c = getb(f); if (c < '0' || c > '9') { ungetb(c, f); break; } } // Multiply by neg without triggering undefined behavior. return (value_t)(neg * i); } #if NEED_INT64 int64_t parse_int64(BFILE *f) { // Parse using uint64_t, which wraps on overflow. uint64_t i = 0; uint64_t neg = 1; int c = getb(f); if (c == '-') { neg = -1; c = getb(f); } for(;;) { i = i * 10 + (c - '0'); c = getb(f); if (c < '0' || c > '9') { ungetb(c, f); break; } } // Multiply by neg without triggering undefined behavior. return (int64_t)(neg * i); } #endif /* NEED_INT64 */ struct forptr *mkForPtr(struct bytestring bs); NODEPTR mkFunPtr(HsFunPtr p); /* Create a forptr that has a free() finalizer. */ struct forptr * mkForPtrFree(struct bytestring str) { struct forptr *fp = mkForPtr(str); /* Create a foreign pointer */ fp->finalizer->final = (HsFunPtr)FREE; /* and set the finalizer to just free it */ return fp; } NODEPTR mkStrNode(struct bytestring str) { NODEPTR n = alloc_node(T_FORPTR); struct forptr *fp = mkForPtrFree(str); FORPTR(n) = fp; fp->finalizer->fptype = FP_BSTR; //printf("mkForPtr n=%p fp=%p %d %s payload.string=%p\n", n, fp, (int)FORPTR(n)->payload.size, (char*)FORPTR(n)->payload.string, FORPTR(n)->payload.string); return n; } /* Table of labelled nodes for sharing during parsing. */ struct shared_entry { heapoffs_t label; NODEPTR node; /* NIL indicates unused */ } *shared_table; heapoffs_t shared_table_size; /* Look for the label in the table. * If it's found, return the node. * If not found, return the first empty entry. */ NODEPTR * find_label(heapoffs_t label) { int i; for(i = (int)label; ; i++) { i %= shared_table_size; if (shared_table[i].node == NIL) { /* The slot is empty, so claim and return it */ shared_table[i].label = label; return &shared_table[i].node; } else if (shared_table[i].label == label) { /* Found the label, so return it. */ return &shared_table[i].node; } /* Not empty and not found, try next. */ } } /* The memory allocated here is never freed. * This could be fixed by using a forptr and a * finalizer for read UTF-8 strings. * Fix this if there is a lot of deserialization. */ struct bytestring parse_string(BFILE *f) { struct bytestring bs; size_t sz = 20; uint8_t *buffer = mmalloc(sz); size_t i; int c; for(i = 0;;) { c = getb(f); if (c == '"') break; if (i >= sz - 1) { sz *= 2; buffer = mrealloc(buffer, sz); } #if 0 if (c == '\\') { buffer[i++] = (uint8_t)parse_int(f); if (!gobble(f, '&')) ERR("parse string"); } else { buffer[i++] = c; } #else /* See src/MicroHs/ExpPrint.hs for how strings are encoded. */ switch (c) { case '\\': c = getb(f); if (c == '?') c = 0x7f; else if (c == '_') c = 0xff; break; case '^': c = getb(f); if (c < 0x40) c &= 0x1f; else c = (c & 0x1f) | 0x80; break; case '|': c = getb(f); c |= 0x80; break; default: /* Unencoded */ ; } buffer[i++] = c; #endif } buffer[i] = 0; /* add a trailing 0 in case we need a C string */ buffer = mrealloc(buffer, i + 1); bs.size = i; bs.string = buffer; //printf("parse_string %d %s\n", (int)bs.size, (char*)bs.string); return bs; } struct forptr *new_mpz(void); NODEPTR parse(BFILE *f) { stackptr_t stk = stack_ptr; NODEPTR r, x, y; NODEPTR *nodep; heapoffs_t l; int c; size_t j; char buf[80]; /* store names of primitives. */ for(;;) { c = getb(f); if (c < 0) ERR("parse EOF"); switch (c) { case ' ': case '\n': continue; } if (num_free < 3) ERR("out of heap reading code"); GCCHECK(1); switch(c) { case '@': x = TOP(0); y = TOP(1); POP(2); PUSH(new_ap(y, x)); break; case '}': x = TOP(0); POP(1); if (stack_ptr != stk) ERR("parse: stack"); return x; #if WANT_GMP case '%': { struct bytestring bs = parse_string(f); /* get all the digits, terminated by " */ struct forptr *fp = new_mpz(); /* a new mpz */ mpz_ptr op = fp->payload.string; /* get actual pointer */ mpz_set_str(op, bs.string, 10); /* convert to an mpz */ free(bs.string); r = alloc_node(T_FORPTR); FORPTR(r) = fp; PUSH(r); break; } #endif case '&': { int is32 = gobble(f, '&'); for (j = 0; (buf[j] = getNT(f)); j++) ; if (is32) { #if WANT_FLOAT32 r = mkFlt32(strtof(buf, NULL)); #else r = alloc_node(T_FLT32); SETVALUE(r, 0); #endif } else { #if WANT_FLOAT64 r = mkFlt64(strtod(buf, NULL)); #else r = alloc_node(T_DBL); SETVALUE(r, 0); #endif } PUSH(r); break; } case '#': #if NEED_INT64 if (gobble(f, '#')) { r = mkInt64(parse_int64(f)); } else { r = mkInt(parse_int(f)); } #else /* NEED_INT64 */ gobble(f, '#'); r = mkInt(parse_int(f)); #endif /* NEED_INT64 */ PUSH(r); break; case '[': { size_t sz; struct ioarray *arr; size_t i; sz = (size_t)parse_int(f); if (!gobble(f, ']')) ERR("parse arr 1"); arr = arr_alloc(sz, NIL); for (i = 0; i < sz; i++) { arr->array[i] = TOP(sz - i - 1); } r = alloc_node(T_ARR); ARR(r) = arr; POP(sz); PUSH(r); break; } case '_': /* Reference to a shared value: _label */ l = parse_int(f); /* The label */ nodep = find_label(l); if (*nodep == NIL) { /* Not yet defined, so make it an indirection */ *nodep = alloc_node(T_FREE); SETINDIR(*nodep, NIL); } PUSH(*nodep); break; case ':': /* Define a shared expression: :label e */ l = parse_int(f); /* The label */ if (!gobble(f, ' ')) ERR("parse ' '"); nodep = find_label(l); x = TOP(0); if (*nodep == NIL) { /* not referenced yet, so add a direct reference */ *nodep = x; } else { /* Sanity check */ if (GETTAG(*nodep) != T_IND || GETINDIR(*nodep) != NIL) ERR("shared != NIL"); SETINDIR(*nodep, x); } break; case '"': /* Everything up to the next " is a string. * Special characters are encoded as \NNN&, * where NNN is the decimal value of the character */ PUSH(mkStrNode(parse_string(f))); break; #if WANT_TICK case '!': if (!gobble(f, '"')) ERR("parse !"); r = alloc_node(T_TICK); SETVALUE(r, (value_t)add_tick_table(parse_string(f));); PUSH(r); break; #endif case '^': /* An FFI name */ for (j = 0; (buf[j] = getNT(f)); j++) ; r = ffiNode(buf); PUSH(r); break; case ';': /* ffe_name; f++) { heapoffs_t l = atoi(f->ffe_name+1); /* the name must be numerical */ f->ffe_value = *find_label(l); } } FREE(shared_table); return n; } counter_t num_shared; /* Two bits per node: marked, shared * 0, 0 -- not visited * 1, 0 -- visited once * 1, 1 -- visited more than once * 0, 1 -- printed */ struct print_bits { bits_t *marked_bits; bits_t *shared_bits; }; static INLINE void set_bit(bits_t *bits, NODEPTR n) { heapoffs_t i = LABEL(n); bits[i / BITS_PER_WORD] |= (1ULL << (i % BITS_PER_WORD)); } #if WANT_STDIO static INLINE void clear_bit(bits_t *bits, NODEPTR n) { heapoffs_t i = LABEL(n); bits[i / BITS_PER_WORD] &= ~(1ULL << (i % BITS_PER_WORD)); } #endif static INLINE int test_bit(bits_t *bits, NODEPTR n) { heapoffs_t i = LABEL(n); return (bits[i / BITS_PER_WORD] & (1ULL << (i % BITS_PER_WORD))) != 0; } size_t strNodes(size_t len); NODEPTR mkStringC(char *str); #if WANT_STDIO void convdbl(char *str, char *fmt, flt64_t x) { /* Using 16 decimals will lose some precision. * 17 would keep the precision, but it frequently looks very ugly. */ (void)snprintf(str, 25, fmt, x); if (strcmp(str, "nan") != 0 && strcmp(str, "-nan") != 0 && strcmp(str, "inf") != 0 && strcmp(str, "-inf") != 0 && !strchr(str, '.') && !strchr(str, 'e') && !strchr(str, 'E')) { /* There is no decimal point and no exponent, so add a decimal point */ strcat(str, ".0"); } } void putdblb(flt64_t x, BFILE *p) { char str[30]; convdbl(str, "%.16g", x); putsb(str, p); } void printrec(BFILE *f, struct print_bits *pb, NODEPTR n, bool prefix); /* Mark all reachable nodes, when a marked node is reached, mark it as shared. */ void find_sharing(struct print_bits *pb, NODEPTR n) { top: while (GETTAG(n) == T_IND) { n = GETINDIR(n); } if (n < cells || n >= cells + heap_size) abort(); //PRINT("find_sharing %p %llu ", n, LABEL(n)); tag_t tag = GETTAG(n); if (tag == T_AP || tag == T_ARR || tag == T_FORPTR) { if (test_bit(pb->shared_bits, n)) { /* Alread marked as shared */ //PRINT("shared\n"); ; } else if (test_bit(pb->marked_bits, n)) { /* Already marked, so now mark as shared */ //PRINT("marked\n"); set_bit(pb->shared_bits, n); num_shared++; } else { /* Mark as visited, and recurse */ //PRINT("unmarked\n"); set_bit(pb->marked_bits, n); switch(tag) { case T_AP: find_sharing(pb, FUN(n)); n = ARG(n); goto top; case T_ARR: for(size_t i = 0; i < ARR(n)->size; i++) { find_sharing(pb, ARR(n)->array[i]); } break; default: break; } } } else { /* Not an sharable node, so do nothing */ //PRINT("not T_AP\n"); ; } } void print_string(BFILE *f, struct bytestring bs) { uint8_t *str = bs.string; putb('"', f); for (size_t i = 0; i < bs.size; i++) { int c = str[i]; #if 0 if (c == '"' || c == '\\' || c < ' ' || c > '~') { putb('\\', f); putdecb(c, f); putb('&', f); } else { putb(c, f); } #else if (c < 0 || c > 0xff) ERR("print_string"); if (c < 0x20) { putb('^', f); putb(c + 0x20, f); } else if (c == '"' || c == '^' || c == '|' || c == '\\') { putb('\\', f); putb(c, f); } else if (c < 0x7f) { putb(c, f); } else if (c == 0x7f) { putb('\\', f); putb('?', f); } else if (c < 0xa0) { putb('^', f); putb(c - 0x80 + 0x40, f); } else if (c < 0xff) { putb('|', f); putb(c - 0x80, f); } else { /* must be< c == 0xff */ putb('\\', f); putb('_', f); } #endif } putb('"', f); } /* * Recursively print an expression. * This assumes that the shared nodes has been marked as such. * The prefix flag is used to get a readable dump. */ void printrec(BFILE *f, struct print_bits *pb, NODEPTR n, bool prefix) { int share = 0; enum node_tag tag; char prbuf[30]; while (GETTAG(n) == T_IND) { /*putb('*', f);*/ n = GETINDIR(n); } if (test_bit(pb->shared_bits, n)) { /* The node is shared */ if (test_bit(pb->marked_bits, n)) { /* Not yet printed, so emit a label */ if (prefix) { putb(':', f); putdecb((value_t)LABEL(n), f); putb(' ', f); } else { share = 1; } clear_bit(pb->marked_bits, n); /* mark as printed */ } else { /* This node has already been printed, so just use a reference. */ putb('_', f); putdecb((value_t)LABEL(n), f); if (!prefix) putb(' ', f); return; } } //if (n == atptr) putb('@', f); tag = GETTAG(n); switch (tag) { case T_AP: if (prefix) { putb('(', f); printrec(f, pb, FUN(n), prefix); putb(' ', f); printrec(f, pb, ARG(n), prefix); putb(')', f); } else { printrec(f, pb, FUN(n), prefix); printrec(f, pb, ARG(n), prefix); putb('@', f); } break; case T_INT: putb('#', f); putdecb(GETVALUE(n), f); break; #if NEED_INT64 case T_INT64: putb('#', f); putb('#', f); putdecb64(GETINT64VALUE(n), f); break; #endif /* NEED_INT64 */ case T_DBL: putb('&', f); putdblb(GETDBLVALUE(n), f); break; case T_FLT32: putb('&', f); putb('&', f); putdblb((double)GETFLTVALUE(n), f); break; case T_WEAK: ERR("serialize WEAK unimplemented"); case T_ARR: if (prefix) { /* Arrays serialize as '[sz] e_1 ... e_sz' */ putb('[', f); putdecb((value_t)ARR(n)->size, f); putb(']', f); for(size_t i = 0; i < ARR(n)->size; i++) { putb(' ', f); printrec(f, pb, ARR(n)->array[i], prefix); } } else { /* Arrays serialize as 'e_1 ... e_sz [sz]' */ for(size_t i = 0; i < ARR(n)->size; i++) { printrec(f, pb, ARR(n)->array[i], prefix); } putb('[', f); putdecb((value_t)ARR(n)->size, f); putb(']', f); } break; case T_PTR: if (prefix) { snprintf(prbuf, sizeof prbuf, "PTR<%p>",PTR(n)); putsb(prbuf, f); } else { ERR("Cannot serialize pointers"); } break; case T_FUNPTR: /* There are a few function pointers that happen without user FFI. * We need to be able to serialize these. * XXX Make a table if we need more. */ if (FUNPTR(n) == 0) { putsb(";0 ", f); } else if (FUNPTR(n) == (HsFunPtr)closeb) { putsb(";closeb ", f); } else if (prefix) { snprintf(prbuf, sizeof prbuf, "FUNPTR<%p>", FUNPTR(n)); putsb(prbuf, f); } else { ERR("Cannot serialize function pointers"); } break; case T_THID: if (prefix) { snprintf(prbuf, sizeof prbuf, "FUNPTR<%d>",(int)THR(n)->mt_id); } else { ERR("cannot serialize ThreadId yet"); } case T_FORPTR: if (n == comb_stdin) putsb("IO.stdin", f); else if (n == comb_stdout) putsb("IO.stdout", f); else if (n == comb_stderr) putsb("IO.stderr", f); #if WANT_GMP else if (FORPTR(n)->finalizer->fptype == FP_MPZ) { /* Serialize as %99999" */ mpz_ptr op = FORPTR(n)->payload.string; /* get the mpz */ int sz = mpz_sizeinbase(op, 10); /* maximum length */ char *s = mmalloc(sz + 2); (void)mpz_get_str(s, 10, op); /* convert to a string */ putsb("%", f); putsb(s, f); putsb("\"", f); /* so we can use parse_string */ free(s); } #endif /* WANT_GMP */ else if (FORPTR(n)->finalizer->fptype == FP_BSTR) { print_string(f, FORPTR(n)->payload); } else if (prefix) { snprintf(prbuf, sizeof prbuf, "FORPTR<%p>",FORPTR(n)); putsb(prbuf, f); } else { ERR("Cannot serialize foreign pointers"); } break; case T_IO_CCALL: putb('^', f); putsb(FFI_IX(GETVALUE(n)).ffi_name, f); break; case T_BADDYN: putb('^', f); putsb(CSTR(n), f); break; case T_TICK: putb('!', f); print_string(f, tick_table[GETVALUE(n)].tick_name); break; default: if (0 <= tag && tag <= T_LAST_TAG) #if WANT_TICK && WANT_TAGNAMES if (tag_names[tag]) putsb(tag_names[tag], f); else #endif { snprintf(prbuf, sizeof prbuf, "TAG=%d", (int)tag); putsb(prbuf, f); } else { snprintf(prbuf, sizeof prbuf, "BADTAG(%d)", (int)tag); putsb(prbuf, f); } break; } if (!prefix) { if (GETTAG(n) != T_AP) putb(' ', f); if (share) { putb(':', f); putdecb((value_t)LABEL(n), f); putb(' ', f); } } } /* Serialize a graph to file. */ void printb(BFILE *f, NODEPTR n, bool header) { struct print_bits pb; num_shared = 0; pb.marked_bits = mcalloc(free_map_nwords, sizeof(bits_t)); pb.shared_bits = mcalloc(free_map_nwords, sizeof(bits_t)); find_sharing(&pb, n); if (header) { putsb(VERSION, f); putdecb(num_shared, f); putb('\n', f); } printrec(f, &pb, n, !header); if (header) { putb('}', f); } FREE(pb.marked_bits); FREE(pb.shared_bits); } /* Show a graph. */ void pps(NODEPTR n) { pp(stdout, n); } void pp(FILE *f, NODEPTR n) { BFILE *bf = add_FILE(f); printb(bf, n, false); putb('\n', bf); freeb_file(bf); } #if 0 NODEPTR *topnode; void ppmsg(const char *msg, NODEPTR n) { printf("%s", msg); pp(stdout, n); printf("\n"); } void dump(const char *msg, NODEPTR at) { atptr = at; printf("dump: %s\n", msg); pp(stdout, *topnode); } #endif #endif /* WANT_STDIO */ NODEPTR mkInt(value_t i) { #if INTTABLE if (LOW_INT <= i && i < HIGH_INT) { return intTable[i - LOW_INT]; } #endif NODEPTR n; n = alloc_node(T_INT); SETVALUE(n, i); return n; } #if NEED_INT64 NODEPTR mkInt64(int64_t i) { NODEPTR n; n = alloc_node(T_INT64); SETINT64VALUE(n, i); return n; } #endif #if WANT_FLOAT32 NODEPTR mkFlt32(flt32_t d) { NODEPTR n; n = alloc_node(T_FLT32); SETFLTVALUE(n, d); return n; } #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 NODEPTR mkFlt64(flt64_t d) { NODEPTR n; n = alloc_node(T_DBL); SETDBLVALUE(n, d); return n; } #endif /* WANT_FLOAT64 */ NODEPTR mkPtr(void* p) { NODEPTR n; n = alloc_node(T_PTR); PTR(n) = p; return n; } NODEPTR mkFunPtr(void (*p)(void)) { NODEPTR n; n = alloc_node(T_FUNPTR); FUNPTR(n) = p; return n; } struct forptr* mkForPtr(struct bytestring bs) { struct final *fin = mcalloc(1, sizeof(struct final)); struct forptr *fp = mcalloc(1, sizeof(struct forptr)); if (bs.size == NOSIZE) { num_fin_alloc++; } else { num_bs_alloc++; num_bs_inuse += bs.size; num_bs_bytes += bs.size; if (num_bs_inuse > num_bs_inuse_max) num_bs_inuse_max = num_bs_inuse; } //printf("mkForPtr p=%p fin=%p fp=%p\n", p, fin, fp); fin->next = final_root; final_root = fin; fin->final = 0; fin->arg = bs.string; fin->size = bs.size; /* The size is not really needed */ fin->back = fp; fin->marked = 0; fp->next = 0; fp->payload = bs; fp->finalizer = fin; // fp->desc = 0; return fp; } struct forptr* mkForPtrP(void *p) { struct bytestring bs = { NOSIZE, p }; return mkForPtr(bs); } struct forptr* addForPtr(struct forptr *ofp, int s) { struct forptr *fp = mmalloc(sizeof(struct forptr)); struct final *fin = ofp->finalizer; fp->next = ofp; fin->back = fp; if (ofp->payload.size != NOSIZE) fp->payload.size = ofp->payload.size - s; fp->payload.string = (uint8_t*)ofp->payload.string + s; fp->finalizer = fin; return fp; } struct forptr* bssubstr(struct forptr *fp, value_t offs, value_t len) { struct forptr *res = addForPtr(fp, offs); res->payload.size = len; return res; } static INLINE NODEPTR mkNil(void) { return combFalse; } static INLINE NODEPTR mkCons(NODEPTR x, NODEPTR xs) { return new_ap(new_ap(combCons, x), xs); } size_t strNodes(size_t len) { /* Each character will need a CHAR node and a CONS node, a CONS uses 2 T_AP nodes */ len *= (1 + 2); /* And each string will need a NIL */ len += 1; return len; } /* Turn a C string into a combinator string. * Does NOT do UTF decoding. */ NODEPTR mkString(struct bytestring bs) { NODEPTR n, nc; size_t i; const unsigned char *str = bs.string; /* no sign bits, please */ n = mkNil(); for(i = bs.size; i > 0; i--) { nc = mkInt(str[i-1]); n = mkCons(nc, n); } return n; } NODEPTR mkStringC(char *str) { struct bytestring bs = { strlen(str), str }; return mkString(bs); } NODEPTR mkStringU(struct bytestring bs) { BFILE *ubuf = add_utf8(openb_rd_mem(bs.string, bs.size)); NODEPTR n, *np, nc; //printf("mkStringU %d %s\n", (int)bs.size, (char*)bs.string); n = mkNil(); np = &n; for(;;) { int c = getb(ubuf); if (c < 0) break; nc = mkInt(c); *np = mkCons(nc, *np); np = &ARG(*np); } closeb(ubuf); return n; } NODEPTR bsunpack(struct bytestring bs) { NODEPTR n, *np, nc; size_t i; n = mkNil(); np = &n; for(i = 0; i < bs.size; i++) { nc = mkInt(((uint8_t *)bs.string)[i]); *np = mkCons(nc, *np); np = &ARG(*np); } return n; } /* XXX This should somehow be merged with other utf8 decoders */ /* Decode first character of a string and optionally return the rest of the string. */ /* Handles regular and modified UTF-8. */ value_t headutf8(struct bytestring bs, void **ret) { uint8_t *p = bs.string; if (bs.size == 0) ERR("headUTF8 0"); int c1 = *p++; if ((c1 & 0x80) == 0) { if (ret) *ret = p; return c1; } if (bs.size == 1) ERR("headUTF8 1"); int c2 = *p++; if ((c1 & 0xe0) == 0xc0) { if (ret) *ret = p; return ((c1 & 0x1f) << 6) | (c2 & 0x3f); } if (bs.size == 2) ERR("headUTF8 2"); int c3 = *p++; if ((c1 & 0xf0) == 0xe0) { if (ret) *ret = p; return ((c1 & 0x0f) << 12) | ((c2 & 0x3f) << 6) | (c3 & 0x3f); } if (bs.size == 3) ERR("headUTF8 3"); int c4 = *p++; if ((c1 & 0xf8) == 0xf0) { if (ret) *ret = p; return ((c1 & 0x07) << 18) | ((c2 & 0x3f) << 12) | ((c3 & 0x3f) << 6) | (c4 & 0x3f); } ERR("headUTF8 4"); NOTREACHED; } /* Evaluate to an INT */ static INLINE value_t evalint(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_INT) { ERR1("evalint, bad tag %s", TAGNAME(GETTAG(n))); } #endif return GETVALUE(n); } #if WANT_FLOAT64 /* Evaluate to a flt64_t */ static INLINE flt64_t evaldbl(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_DBL) { ERR1("evaldbl, bad tag %s", TAGNAME(GETTAG(n))); } #endif return GETDBLVALUE(n); } #endif /* WANT_FLOAT64 */ #if WANT_FLOAT32 /* Evaluate to a flt32_t */ static INLINE flt32_t evalflt(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_FLT32) { ERR1("evaldbl, bad tag %s", TAGNAME(GETTAG(n))); } #endif return GETFLTVALUE(n); } #endif /* WANT_FLOAT32 */ /* Evaluate to a T_PTR */ void * evalptr(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_PTR) { ERR1("evalptr, bad tag %s", TAGNAME(GETTAG(n))); } #endif return PTR(n); } /* Evaluate to a T_FUNPTR */ HsFunPtr evalfunptr(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_FUNPTR) { ERR1("evalfunptr, bad tag %s", TAGNAME(GETTAG(n))); } #endif return FUNPTR(n); } /* Evaluate to a T_FORPTR */ struct forptr * evalforptr(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_FORPTR) { ERR1("evalforptr, bad tag %s", TAGNAME(GETTAG(n))); } #endif return FORPTR(n); } /* Evaluate to a bytestring */ struct forptr * evalbstr(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_FORPTR || FORPTR(n)->finalizer->fptype != FP_BSTR) { ERR1("evalbstr, bad tag %s", TAGNAME(GETTAG(n))); } #endif return FORPTR(n); } /* Evaluate to a T_THID */ struct mthread * evalthid(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_THID) { ERR1("evalthid, bad tag %s", TAGNAME(GETTAG(n))); } #endif return THR(n); } /* Evaluate to a T_MVAR */ struct mvar * evalmvar(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_MVAR) { ERR1("evalmvar, bad tag %s", TAGNAME(GETTAG(n))); } #endif return MVAR(n); } /* Evaluate to a T_WEAK */ void * evalweak(NODEPTR n) { n = evali(n); #if SANITY if (GETTAG(n) != T_WEAK) { ERR1("evalweak, bad tag %s", TAGNAME(GETTAG(n))); } #endif return WEAK(n); } /* Evaluate a string, returns a newly allocated buffer. * XXX this is cheating, should use continuations. * XXX the malloc()ed string is leaked if we yield in here. * Caller is responsible to free(). * Does modified UTF-8 encoding. */ struct bytestring evalstring(NODEPTR n) { size_t sz = 100; char *buf = mmalloc(sz); size_t offs; uvalue_t c; NODEPTR x; struct bytestring bs; for (offs = 0;;) { if (offs >= sz - 4) { sz *= 2; buf = mrealloc(buf, sz); } PUSH(n); /* protect the list from GC */ n = evali(n); POP(1); if (GETTAG(n) == T_K) /* Nil */ break; else if (GETTAG(n) == T_AP && GETTAG(x = indir(&FUN(n))) == T_AP && GETTAG(indir(&FUN(x))) == T_O) { /* Cons */ PUSH(n); /* protect from GC */ c = evalint(ARG(x)); n = POPTOP(); if ((c & 0x1ff800) == 0xd800) { // c is a surrogate c = 0xfffd; // replacement character } if (0 < c && c < 0x80) { /* exclude 0, since this is modified UTF-8 */ buf[offs++] = (char)c; } else if (c < 0x800) { /* 0 encodes here, with an over-long representation */ buf[offs++] = ((c >> 6 ) ) | 0xc0; buf[offs++] = ((c ) & 0x3f) | 0x80; } else if (c < 0x10000) { buf[offs++] = ((c >> 12) ) | 0xe0; buf[offs++] = ((c >> 6 ) & 0x3f) | 0x80; buf[offs++] = ((c ) & 0x3f) | 0x80; } else if (c < 0x110000) { buf[offs++] = ((c >> 18) ) | 0xf0; buf[offs++] = ((c >> 12) & 0x3f) | 0x80; buf[offs++] = ((c >> 6 ) & 0x3f) | 0x80; buf[offs++] = ((c ) & 0x3f) | 0x80; } else { ERR("invalid char"); } n = ARG(n); } else { ERR("evalstring not Nil/Cons"); } } buf[offs] = 0; /* in case we use it as a C string */ bs.size = offs; bs.string = buf; return bs; } /* Does not do UTF-8 encoding */ struct bytestring evalbytestring(NODEPTR n) { size_t sz = 100; uint8_t *buf = mmalloc(sz); size_t offs; uvalue_t c; NODEPTR x; struct bytestring bs; for (offs = 0;;) { if (offs >= sz - 1) { sz *= 2; buf = mrealloc(buf, sz); } PUSH(n); /* protect list from GC */ n = evali(n); POP(1); if (GETTAG(n) == T_K) /* Nil */ break; else if (GETTAG(n) == T_AP && GETTAG(x = indir(&FUN(n))) == T_AP && GETTAG(indir(&FUN(x))) == T_O) { /* Cons */ PUSH(n); /* protect from GC */ c = evalint(ARG(x)); n = POPTOP(); buf[offs++] = c; n = ARG(n); } else { //pp(stdout, n); ERR("evalbytestring not Nil/Cons"); } } buf[offs] = 0; /* in case we use it as a C string */ bs.size = offs; bs.string = buf; return bs; } struct bytestring bsreplicate(size_t size, uint8_t value) { struct bytestring bs; bs.size = size; bs.string = mmalloc(size); memset(bs.string, value, size); return bs; } struct bytestring bsappend(struct bytestring p, struct bytestring q) { struct bytestring r; r.size = p.size + q.size; r.string = mmalloc(r.size); memcpy(r.string, p.string, p.size); memcpy((uint8_t *)r.string + p.size, q.string, q.size); return r; } struct bytestring bsappenddot(struct bytestring p, struct bytestring q) { struct bytestring r; r.size = p.size + q.size + 1; r.string = mmalloc(r.size); memcpy(r.string, p.string, p.size); memcpy((uint8_t *)r.string + p.size, ".", 1); memcpy((uint8_t *)r.string + p.size + 1, q.string, q.size); return r; } /* * Compare bytestrings. * We can't use memcmp() directly for two reasons: * - the two strings can have different lengths * - the return value is only guaranteed to be ==0 or !=0 */ int bscompare(struct bytestring bsp, struct bytestring bsq) { uint8_t *p = bsp.string; uint8_t *q = bsq.string; size_t len = bsp.size < bsq.size ? bsp.size : bsq.size; while (len--) { int r = (int)*p++ - (int)*q++; if (r) { /* Unequal bytes found. */ if (r < 0) return -1; if (r > 0) return 1; return 0; } } /* Got to the end of the shorter string. */ /* The shorter string is considered smaller. */ if (bsp.size < bsq.size) return -1; if (bsp.size > bsq.size) return 1; return 0; } void rnf_rec(bits_t *done, NODEPTR n) { top: if (test_bit(done, n)) return; set_bit(done, n); n = evali(n); if (GETTAG(n) == T_AP) { PUSH(ARG(n)); /* protect from GC */ rnf_rec(done, FUN(n)); n = POPTOP(); goto top; } } void rnf(value_t noerr, NODEPTR n) { /* Mark visited nodes to avoid getting stuck in loops. */ bits_t *done = mcalloc(free_map_nwords, sizeof(bits_t)); if (doing_rnf) ERR("recursive rnf()"); doing_rnf = (bool)noerr; rnf_rec(done, n); doing_rnf = false; FREE(done); } /* Evaluate a node, returns when the node is in WHNF. */ NODEPTR evali(NODEPTR an) { NODEPTR n = an; stackptr_t stk = stack_ptr; NODEPTR x, y, z, w; value_t xi, yi, r; struct forptr *xfp; char *msg; heapoffs_t l; enum node_tag tag; struct ioarray *arr; struct bytestring xbs, ybs, rbs; #if WANT_STDIO void *bfile; int hdr; #endif /* WANT_STDIO */ #if MAXSTACKDEPTH counter_t old_cur_c_stack = cur_c_stack; if (++cur_c_stack > max_c_stack) max_c_stack = cur_c_stack; #endif /* Reset stack pointer and return. */ #define RET do { goto ret; } while(0) #define HASNARGS(n) (stack_ptr - stk >= (n)) /* Check that there are at least n arguments, return if not. */ #define CHECK(n) do { if (!HASNARGS(n)) RET; } while(0) #define SETIND(n, x) SETINDIR(n, x) #define GOIND(x) do { NODEPTR _x = (x); SETIND(n, _x); n = _x; goto top; } while(0) #define GOAP(f,a) do { FUN(n) = (f); ARG(n) = (a); goto ap; } while(0) #define GOAP2(f,a,b) do { FUN(n) = new_ap((f), (a)); ARG(n) = (b); goto ap2; } while(0) #define GOPAIR(a) do { FUN(n) = new_ap(combPair, (a)); goto ap; } while(0) #define GOPAIRUNIT do { FUN(n) = combPairUnit; goto ap; } while(0) /* CHKARGN checks that there are at least N arguments. * It also * - sets n to the "top" node * - set x, y, ... to the arguments * - pops N stack elements * NOTE: No GC is allowed after these, since the stack has been popped. */ #define CHKARG0 do { } while(0) #define CHKARG1 do { CHECK(1); POP(1); n = TOP(-1); x = ARG(n); } while(0) #define CHKARG2 do { CHECK(2); POP(2); n = TOP(-1); y = ARG(n); x = ARG(TOP(-2)); } while(0) #define CHKARG3 do { CHECK(3); POP(3); n = TOP(-1); z = ARG(n); y = ARG(TOP(-2)); x = ARG(TOP(-3)); } while(0) #define CHKARG4 do { CHECK(4); POP(4); n = TOP(-1); w = ARG(n); z = ARG(TOP(-2)); y = ARG(TOP(-3)); x = ARG(TOP(-4)); } while(0) #define CHKARG5 do { CHECK(5); POP(5); n = TOP(-1); /*v = ARG(n);*/ w = ARG(TOP(-2)); z = ARG(TOP(-3)); y = ARG(TOP(-4)); x = ARG(TOP(-5)); } while(0) /* Non-popping versions */ #define CHKARG1NP do { CHECK(1); n = TOP(0); x = ARG(n); } while(0) #define CHKARG2NP do { CHECK(2); n = TOP(1); y = ARG(n); x = ARG(TOP(0)); } while(0) #define CHKARG3NP do { CHECK(3); n = TOP(2); z = ARG(n); y = ARG(TOP(1)); x = ARG(TOP(0)); } while(0) #define CHKARG4NP do { CHECK(4); n = TOP(3); w = ARG(n); z = ARG(TOP(2)); y = ARG(TOP(1)); x = ARG(TOP(0)); } while(0) /* Alloc a possible GC action, e, between setting x and popping */ #define CHKARGEV1(e) do { CHECK(1); x = ARG(TOP(0)); e; POP(1); n = TOP(-1); } while(0) #define SETINT(n,r) do { SETTAG((n), T_INT); SETVALUE((n), (r)); } while(0) #define SETINT64(n,r) do { SETTAG((n), T_INT64); SETINT64VALUE((n), (r)); } while(0) #define SETDBL(n,d) do { SETTAG((n), T_DBL); SETDBLVALUE((n), (d)); } while(0) #define SETFLT(n,d) do { SETTAG((n), T_FLT32); SETFLTVALUE((n), (d)); } while(0) #define SETPTR(n,r) do { SETTAG((n), T_PTR); PTR(n) = (r); } while(0) #define SETFUNPTR(n,r) do { SETTAG((n), T_FUNPTR); FUNPTR(n) = (r); } while(0) #define SETFORPTR(n,r) do { SETTAG((n), T_FORPTR); FORPTR(n) = (r); } while(0) #define SETBSTR(n,r) do { SETTAG((n), T_FORPTR); FORPTR(n) = (r); FORPTR(n)->finalizer->fptype = FP_BSTR; } while(0) #define OPINT1(e) do { CHECK(1); xi = evalint(ARG(TOP(0))); e; POP(1); n = TOP(-1); } while(0); #define OPPTR2(e) do { CHECK(2); xp = evalptr(ARG(TOP(0))); yp = evalptr(ARG(TOP(1))); e; POP(2); n = TOP(-1); } while(0); #define CMPP(op) do { OPPTR2(r = xp op yp); GOIND(r ? combTrue : combFalse); } while(0) top: /*pp(stdout, an);*/ if (--glob_slice <= 0) yield(); l = LABEL(n); if (l < T_IO_STDIN) { /* The node is one of the permanent nodes; the address offset is the tag */ tag = l; } else { /* Heap allocated node */ if (ISINDIR(n)) { /* Follow indirections */ NODEPTR on = n; do { n = GETINDIR(n); } while(ISINDIR(n)); SETINDIR(on, n); /* and short-circuit them */ } tag = GETTAG(n); } //printf("%s %d\n", tag_names[tag], (int)stack_ptr); //if (stack_ptr < -1) // ERR("stack_ptr"); switch (tag) { ap2: PUSH(n); n = FUN(n); ap: case T_AP: PUSH(n); n = FUN(n); goto top; case T_INT: RET; case T_DBL: RET; #if NEED_INT64 case T_INT64: RET; #endif /* NEED_INT64 */ case T_FLT32: RET; case T_PTR: RET; case T_FUNPTR: RET; case T_FORPTR: RET; case T_ARR: RET; case T_THID: RET; case T_MVAR: RET; case T_WEAK: RET; case T_BADDYN: ERR1("FFI unknown %s", CSTR(n)); /* * Some of these reductions, (e.g., Z x y = K (x y)) are there to avoid * that increase in arity that some "optimizations" in Abstract.hs * stop reductions from happening. This can be important for "full laziness". * In practice, these reductions almost never happen, but there they are anyway. :) */ case T_S: GCCHECK(2); CHKARG3; GOAP2(x, z, new_ap(y, z)); /* S x y z = x z (y z) */ case T_SS: GCCHECK(3); CHKARG4; GOAP2(x, new_ap(y, w), new_ap(z, w)); /* S' x y z w = x (y w) (z w) */ case T_K: CHKARG2; GOIND(x); /* K x y = *x */ case T_A: CHKARG2; GOIND(y); /* A x y = *y */ case T_U: CHKARG2; GOAP(y, x); /* U x y = y x */ case T_I: CHKARG1; GOIND(x); /* I x = *x */ case T_Y: CHKARG1; GOAP(x, n); /* n@(Y x) = x n */ case T_B: GCCHECK(1); CHKARG3; GOAP(x, new_ap(y, z)); /* B x y z = x (y z) */ case T_BB: if (!HASNARGS(4)) { GCCHECK(1); CHKARG2; COUNT(red_bb); GOAP(combB, new_ap(x, y)); } else { /* B' x y = B (x y) */ GCCHECK(2); CHKARG4; GOAP2(x, y, new_ap(z, w)); } /* B' x y z w = x y (z w) */ case T_Z: if (!HASNARGS(3)) { GCCHECK(1); CHKARG2; COUNT(red_z); GOAP(combK, new_ap(x, y)); } else { /* Z x y = K (x y) */ CHKARG3; GOAP(x, y); } /* Z x y z = x y */ //case T_J: CHKARG3; GOAP(z, x); /* J x y z = z x */ t_c: case T_C: GCCHECK(1); CHKARG3; GOAP2(x, z, y); /* C x y z = x z y */ case T_CC: GCCHECK(2); CHKARG4; GOAP2(x, new_ap(y, w), z); /* C' x y z w = x (y w) z */ t_p: case T_P: GCCHECK(1); CHKARG3; GOAP2(z, x, y); /* P x y z = z x y */ case T_R: if(!HASNARGS(3)) { GCCHECK(1); CHKARG2; COUNT(red_r); GOAP2(combC, y, x); } else { /* R x y = C y x */ GCCHECK(1); CHKARG3; GOAP2(y, z, x); } /* R x y z = y z x */ case T_O: GCCHECK(1); CHKARG4; GOAP2(w, x, y); /* O x y z w = w x y */ case T_K2: if (!HASNARGS(3)) { CHKARG2; COUNT(red_k2); GOAP(combK, x); } else { /* K2 x y = K x */ CHKARG3; GOIND(x); } /* K2 x y z = *x */ case T_K3: if (!HASNARGS(4)) { CHKARG2; COUNT(red_k3); GOAP(combK2, x); } else { /* K3 x y = K2 x */ CHKARG4; GOIND(x); } /* K3 x y z w = *x */ case T_K4: if (!HASNARGS(5)) { CHKARG2; COUNT(red_k4); GOAP(combK3, x); } else { /* K4 x y = K3 x */ CHKARG5; GOIND(x); } /* K4 x y z w v = *x */ case T_CCB: if (!HASNARGS(4)) { GCCHECK(2); CHKARG3; COUNT(red_ccb); GOAP2(combB, new_ap(x, z), y);} else{ /* C'B x y z = B (x z) y */ GCCHECK(2); CHKARG4; GOAP2(x, z, new_ap(y, w)); } /* C'B x y z w = x z (y w) */ /* * Strict primitives require evaluating the arguments before we can proceed. * The easiest way to do this is to just recursively call evali() for each argument. * The drawback of this is that it uses a lot of C stack. (E.g., recompiling MicroHs * uses a stack depth of 1800). * Instead we use the following scheme: * When we find a strict binary (int) primitive we push T_BININT2, * set n=second argument. * Continue evaluation of n. * When n is finally evaluated and we are about to return we check if the stack top is T_BININT2. * If so, change the stack top to T_BININT1, * set n=first argument. * Continue evaluation of n. * When n is finally evaluated and we are about to return we check if the stack top is T_BININT1. * If so, we know that both arguments are now evaluated, and we perform the strict operation. * * On my desktop machine this is about 3% slower, on my laptop (Apple M1) it is about 3% faster. * * Pictorially for BININT * Before the code below: * ---- * | --------> @ * ---- / \ * | ------> @ y * ---- / \ * n ----> ADD x * * After * ---- * | --------> @ * ---- / \ * | ------> @ y * ---- / \ * | ->BI2 ADD x * ---- ^ * n ----------| * * x becomes an INT, stack is not empty, BININT2 found on top * ---- * | --------> @ * ---- / \ * | ------> @ y * ---- / \ * | ->BI2 ADD INT * ---- ^ * n ----------| * * After * ---- * | --------> @ * ---- / \ * | ------> @ y * ---- / \ \ * | ->BI1 ADD INT | * ---- | * n ---------------| * * y becomes an INT, stack is not empty, BININT1 found on top * do arithmetic * ---- * | --------> @ * ---- / \ * | ------> @ INT * ---- / \ \ * | ->BI1 ADD INT | * ---- | * n ---------------| * * ---- * n -------> INT(x+y) */ case T_ADD: case T_SUB: case T_MUL: case T_QUOT: case T_REM: case T_SUBR: case T_UQUOT: case T_UREM: case T_AND: case T_OR: case T_XOR: case T_SHL: case T_SHR: case T_ASHR: case T_EQ: case T_NE: case T_LT: case T_LE: case T_GT: case T_GE: case T_ICMP: case T_ULT: case T_ULE: case T_UGT: case T_UGE: case T_UCMP: CHECK(2); n = ARG(TOP(1)); if (GETTAG(n) == T_INT) { n = ARG(TOP(0)); PUSH(combBININT1); if (GETTAG(n) == T_INT) goto binint1; } else { PUSH(combBININT2); } goto top; case T_NEG: case T_INV: case T_POPCOUNT: case T_CLZ: case T_CTZ: CHECK(1); n = ARG(TOP(0)); PUSH(combUNINT1); goto top; #if WANT_FLOAT32 case T_FADD: case T_FSUB: case T_FMUL: case T_FDIV: case T_FEQ: case T_FNE: case T_FLT: case T_FLE: case T_FGT: case T_FGE: CHECK(2); n = ARG(TOP(1)); PUSH(combBINFLT2); goto top; case T_FNEG: CHECK(1); n = ARG(TOP(0)); PUSH(combUNFLT1); goto top; case T_I64TOF: { #if WANT_INT64 || WORD_SIZE == 64 CHECK(1); x = evali(ARG(TOP(0))); #if SANITY if (GETTAG(x) != T_INT64) ERR("T_INT64 tag"); #endif flt32_t rf = (flt32_t)GETINT64VALUE(x); POP(1); n = TOP(-1); SETFLT(n, rf); RET; #else ERR("No Int64"); #endif } case T_ITOF: { CHECK(1); x = evali(ARG(TOP(0))); #if SANITY if (GETTAG(x) != T_INT) ERR("T_ITOF tag"); #endif flt32_t rf = (flt32_t)GETVALUE(x); POP(1); n = TOP(-1); SETFLT(n, rf); RET; } #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 case T_DADD: case T_DSUB: case T_DMUL: case T_DDIV: case T_DEQ: case T_DNE: case T_DLT: case T_DLE: case T_DGT: case T_DGE: CHECK(2); n = ARG(TOP(1)); PUSH(combBINDBL2); goto top; case T_DNEG: CHECK(1); n = ARG(TOP(0)); PUSH(combUNDBL1); goto top; #if WANT_INT64 || WORD_SIZE == 64 case T_I64TOD: { CHECK(1); x = evali(ARG(TOP(0))); #if SANITY if (GETTAG(x) != T_INT64) ERR("T_INT64 tag"); #endif flt64_t rd = (flt64_t)GETINT64VALUE(x); POP(1); n = TOP(-1); SETDBL(n, rd); RET; } #endif case T_ITOD: { CHECK(1); x = evali(ARG(TOP(0))); #if SANITY if (GETTAG(x) != T_INT) ERR("T_ITOD tag"); #endif flt64_t rd = (flt64_t)GETVALUE(x); POP(1); n = TOP(-1); SETDBL(n, rd); RET; } #endif /* WANT_FLOAT64 */ case T_ISINT: CHECK(1); x = evali(ARG(TOP(0))); POP(1); n = TOP(-1); SETINT(n, GETTAG(x) == T_INT ? GETVALUE(x) : -1); RET; case T_BSAPPEND: case T_BSAPPENDDOT: case T_BSEQ: case T_BSNE: case T_BSLT: case T_BSLE: case T_BSGT: case T_BSGE: case T_BSCMP: CHECK(2); n = ARG(TOP(1)); PUSH(combBINBS2); goto top; #if NEED_INT64 case T_ADD64: case T_SUB64: case T_MUL64: case T_QUOT64: case T_REM64: case T_SUBR64: case T_UQUOT64: case T_UREM64: case T_AND64: case T_OR64: case T_XOR64: case T_SHL64: case T_SHR64: case T_ASHR64: case T_EQ64: case T_NE64: case T_LT64: case T_LE64: case T_GT64: case T_GE64: case T_ICMP64: case T_ULT64: case T_ULE64: case T_UGT64: case T_UGE64: case T_UCMP64: CHECK(2); n = ARG(TOP(1)); if (GETTAG(n) == T_INT64) { n = ARG(TOP(0)); PUSH(combBININT64_1); if (GETTAG(n) == T_INT64) goto binint64_1; } else { PUSH(combBININT64_2); } goto top; case T_NEG64: case T_INV64: case T_POPCOUNT64: case T_CLZ64: case T_CTZ64: CHECK(1); n = ARG(TOP(0)); PUSH(combUNINT64_1); goto top; #endif /* NEED_INT64 */ /* XXX This needs redoing with Int64 */ /* Retag a word sized value, keeping the value bits */ #define CONV(t, set, get) do { CHECK(1); x = evali(ARG(TOP(0))); n = POPTOP(); SETTAG(n, t); set(n, get(x)); RET; } while(0) #if WANT_INT64 case T_TODBL: CONV(T_DBL, SETINT64VALUE, GETINT64VALUE); /* raw int64_t -> double */ case T_FROMDBL: CONV(T_INT64, SETINT64VALUE, GETINT64VALUE); case T_ITOI64: CONV(T_INT64, SETINT64VALUE, GETVALUE); case T_UTOU64: CONV(T_INT64, SETINT64VALUE, (uint64_t)GETVALUE); case T_I64TOI: CONV(T_INT, SETVALUE, GETINT64VALUE); case T_U64TOU: CONV(T_INT, SETVALUE, GETINT64VALUE); #endif #if WANT_FLOAT32 case T_TOFLT: CONV(T_FLT32, SETINT32VALUE, GETINT32VALUE); case T_FROMFLT: CONV(T_INT, SETVALUE, GETINT32VALUE); #endif case T_TOINT: CONV(T_INT, SETVALUE, GETVALUE); case T_TOPTR: CONV(T_PTR, SETVALUE, GETVALUE); case T_TOFUNPTR: CONV(T_FUNPTR, SETVALUE, GETVALUE); #undef CONV case T_FPADD: CHECK(2); xfp = evalforptr(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); SETFORPTR(n, addForPtr(xfp, yi)); RET; case T_FP2P: CHECK(1); xfp = evalforptr(ARG(TOP(0))); POP(1); n = TOP(-1); SETPTR(n, xfp->payload.string); RET; case T_FP2BS: CHECK(2); xfp = evalforptr(ARG(TOP(0))); xi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); xfp->payload.size = xi; SETBSTR(n, xfp); RET; case T_BS2FP: CHECK(1); xfp = evalbstr(ARG(TOP(0))); POP(1); n = TOP(-1); SETFORPTR(n, xfp); RET; case T_ARR_EQ: { CHECK(2); x = evali(ARG(TOP(0))); arr = ARR(x); y = evali(ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(arr == ARR(y) ? combTrue : combFalse); } case T_BSTOUTF8: { CHECK(1); n = ARG(TOP(0)); /* Zap the pointer to the list so it can be GC:ed. * The actual list is protected from GC by evalbytestring(). */ // ARG(TOP(0)) = combK; struct bytestring bs = evalstring(n); POP(1); n = TOP(-1); SETBSTR(n, mkForPtrFree(bs)); RET; } case T_BSHEADUTF8: CHECK(1); xfp = evalbstr(ARG(TOP(0))); POP(1); n = TOP(-1); SETINT(n, headutf8(xfp->payload, (void**)0)); RET; case T_BSTAILUTF8: CHECK(1); xfp = evalbstr(ARG(TOP(0))); POP(1); n = TOP(-1); { void *out; (void)headutf8(xfp->payload, &out); /* skip one UTF8 character */ xi = (char*)out - (char*)xfp->payload.string; /* offset */ yi = xfp->payload.size - xi; /* remaining length */ SETBSTR(n, bssubstr(xfp, xi, yi)); /* make a substring */ } RET; case T_BSFROMUTF8: if (doing_rnf) RET; CHECK(1); xfp = evalbstr(ARG(TOP(0))); GCCHECK(strNodes(xfp->payload.size)); POP(1); n = TOP(-1); //printf("T_FROMUTF8 x = %p fp=%p payload.string=%p\n", x, x->uarg.uuforptr, x->uarg.uuforptr->payload.string); GOIND(mkStringU(xfp->payload)); case T_BSUNPACK: if (doing_rnf) RET; CHECK(1); struct forptr *xfp = evalbstr(ARG(TOP(0))); GCCHECK(strNodes(xfp->payload.size)); POP(1); n = TOP(-1); GOIND(bsunpack(xfp->payload)); case T_BSPACK: CHECK(1); n = ARG(TOP(0)); /* Zap the pointer to the list so it can be GC:ed. * The actual list is protected from GC by evalbytestring(). */ ARG(TOP(0)) = combK; struct bytestring rbs = evalbytestring(n); POP(1); n = TOP(-1); SETBSTR(n, mkForPtrFree(rbs)); RET; case T_BSREPLICATE: CHECK(2); xi = evalint(ARG(TOP(0))); yi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); SETBSTR(n, mkForPtrFree(bsreplicate(xi, yi))); RET; case T_BSLENGTH: CHECK(1); xfp = evalbstr(ARG(TOP(0))); POP(1); n = TOP(-1); SETINT(n, xfp->payload.size); RET; case T_BSSUBSTR: CHECK(3); xfp = evalbstr(ARG(TOP(0))); xi = evalint(ARG(TOP(1))); yi = evalint(ARG(TOP(2))); POP(3); n = TOP(-1); SETBSTR(n, bssubstr(xfp, xi, yi)); RET; case T_BSINDEX: CHECK(2); xfp = evalbstr(ARG(TOP(0))); xi = evalint(ARG(TOP(1))); POP(2); n = TOP(-1); SETINT(n, ((uint8_t *)xfp->payload.string)[xi]); RET; case T_BSWRITE: CHKARG4NP; xfp = evalbstr(x); xi = evalint(y); yi = evalint(z); POP(4); ((uint8_t *)xfp->payload.string)[xi] = (uint8_t)yi; GOPAIRUNIT; case T_RAISE: if (doing_rnf) RET; CHKARG1; raise_exn(x); /* never returns */ case T_SPNEW: GCCHECK(1); CHKARG2; xi = new_stableptr(x); GOPAIR(mkInt(xi)); case T_SPDEREF: CHKARG2NP; xi = evalint(x); POP(2); GOPAIR(deref_stableptr(xi)); case T_SPFREE: CHKARG2NP; xi = evalint(x); free_stableptr(xi); POP(2); GOPAIRUNIT; case T_WKNEW: GCCHECK(2); CHKARG3; GOPAIR(new_weak_ptr(x, y, 0)); case T_WKNEWFIN: GCCHECK(3); CHKARG4; GOPAIR(new_weak_ptr(x, y, z)); case T_WKDEREF: CHKARG2NP; x = deref_weak_ptr(evalweak(x)); POP(2); GOPAIR(x); case T_WKFINAL: CHKARG2NP; finalize_weak_ptr(evalweak(x)); POP(2); GOPAIRUNIT; case T_SEQ: CHECK(2); evali(ARG(TOP(0))); POP(2); n = TOP(-1); y = ARG(n); GOIND(y); /* seq x y = eval(x); y */ case T_RNF: if (doing_rnf) RET; CHECK(2); xi = evalint(ARG(TOP(0))); rnf(xi, ARG(TOP(1))); POP(2); n = TOP(-1); GOIND(combUnit); case T_IO_PERFORMIO: GCCHECK(2); if (doing_rnf) RET; CHKARG1; /* Conjure up a new world and evaluate the io with that world, finally selecting the result */ /* PERFORMIO io --> io World K */ #if 1 GOAP2(x, combWorld, combK); #else { /* Don't count performio reductions. */ /* Useful when Debug.Trace.trace should have zero cost */ NODEPTR p1 = new_ap(x, combWorld); NODEPTR p2 = new_ap(p1, combK); counter_t s = glob_slice; glob_slice = 1000000000; NODEPTR p3 = evali(p2); glob_slice = s; GOIND(p3); } #endif case T_IO_BIND: goto t_c; case T_IO_RETURN: goto t_p; case T_IO_THEN: GCCHECK(2); CHKARG2; GOAP2(combIOBIND, x, new_ap(combK, y)); #if WANT_STDIO case T_IO_PP: CHKARG2; pp(stderr, x); GOPAIRUNIT; case T_IO_PRINT: hdr = false; goto ser; case T_IO_SERIALIZE: hdr = true; ser: #if 0 gc(); /* DUBIOUS: do a GC to get possible GC reductions */ #endif CHKARG3NP; bfile = (struct BFILE*)evalptr(x); printb(bfile, evali(y), hdr); putb('\n', bfile); POP(3); GOPAIRUNIT; case T_IO_DESERIALIZE: CHKARG2NP; bfile = (struct BFILE*)evalptr(x); gc(); /* make sure we have room. GC during parse is dodgy. */ x = parse_top(bfile, 0); POP(2); GOPAIR(x); /* allocates a cell, but we did a GC above */ #endif #if WANT_ARGS case T_IO_GETARGREF: GCCHECK(2); CHKARG1; x = alloc_node(T_ARR); ARR(x) = argarray; GOPAIR(x); #endif case T_IO_CCALL: { GCCHECK(1); /* room for placeholder */ int a = (int)GETVALUE(n); /* function number */ //printf(" %s\n", FFI_IX(a).ffi_name); int arity = FFI_IX(a).ffi_arity; CHECK(arity); funptr_t f = FFI_IX(a).ffi_fun; PUSH(mkPtr(0)); /* placeholder for result, protected from GC */ int k = f(stk); /* call FFI function, return number of arguments */ if (k != arity) { #if WANT_STDIO fprintf(stderr, "ccall arity %s %d!=%d\n", FFI_IX(a).ffi_name, arity, k); #endif ERR("ccall arity"); /* temporary sanity check */ } GCCHECK(1); /* room for pair */ x = POPTOP(); /* pop actual result */ POP(arity); /* pop the pushed arguments */ if (stack_ptr < 0) ERR("CCALL POP"); n = POPTOP(); /* node to update */ GOPAIR(x); /* and this is the result */ } case T_NEWCASTRINGLEN: { CHKARG2NP; /* set x,y,n */ struct bytestring bs = evalbytestring(x); GCCHECK(5); NODEPTR cs = alloc_node(T_PTR); PTR(cs) = bs.string; NODEPTR res = new_ap(new_ap(combPair, cs), mkInt(bs.size)); POP(2); GOPAIR(res); } case T_PACKCSTRING: { CHKARG2NP; /* sets x, y, n */ char *cstr = evalptr(x); size_t size = strlen(cstr); char *str = mmalloc(size); memcpy(str, cstr, size); struct bytestring bs = { size, str }; NODEPTR res = mkStrNode(bs); GCCHECKSAVE(res, 1); POP(2); GOPAIR(res); } case T_PACKCSTRINGLEN: { CHKARG3NP; /* sets x,y,z,n */ char *cstr = evalptr(x); size_t size = evalint(y); char *str = mmalloc(size); memcpy(str, cstr, size); struct bytestring bs = { size, str }; NODEPTR res = mkStrNode(bs); POP(3); GCCHECKSAVE(res, 1); GOPAIR(res); } case T_BSGRAB: { CHKARG2NP; /* sets x, y, n */ char *cstr = evalptr(x); size_t size = strlen(cstr); struct bytestring bs = { size, cstr }; NODEPTR res = mkStrNode(bs); GCCHECKSAVE(res, 1); POP(2); GOPAIR(res); } case T_ARR_ALLOC: { CHKARG3NP; /* sets x,y,z,n */ size_t size = evalint(x); struct ioarray *arr = arr_alloc(size, y); GCCHECK(2); NODEPTR res = alloc_node(T_ARR); ARR(res) = arr; POP(3); GOPAIR(res); } case T_ARR_COPY: { CHKARG2NP; NODEPTR a = evali(x); if (GETTAG(a) != T_ARR) ERR("T_ARR_COPY tag"); struct ioarray *arr = arr_copy(ARR(a)); GCCHECK(2); NODEPTR res = alloc_node(T_ARR); ARR(res) = arr; POP(2); GOPAIR(res); } case T_ARR_SIZE: { CHKARG2NP; NODEPTR a = evali(x); if (GETTAG(a) != T_ARR) ERR("bad ARR tag"); GCCHECK(2); NODEPTR res = mkInt(ARR(a)->size); POP(2); GOPAIR(res); } case T_ARR_READ: { CHKARG3NP; /* sets x,y,n */ size_t i = evalint(y); NODEPTR a = evali(x); if (GETTAG(a) != T_ARR) ERR("bad ARR tag"); if (i >= ARR(a)->size) ERR("ARR_READ"); GCCHECK(1); NODEPTR res = ARR(a)->array[i]; POP(3); GOPAIR(res); } case T_ARR_WRITE: { CHKARG4NP; /* sets x,y,z,n */ size_t i = evalint(y); NODEPTR a = evali(x); if (GETTAG(a) != T_ARR) ERR("bad ARR tag"); if (i >= ARR(a)->size) { ERR("ARR_WRITE"); } ARR(a)->array[i] = z; POP(4); GOPAIRUNIT; } case T_ARR_TRUNC: { CHKARG3NP; /* sets x,y,n */ size_t i = evalint(y); NODEPTR a = evali(x); if (GETTAG(a) != T_ARR) ERR("bad ARR tag"); if (i >= ARR(a)->size) { ERR("ARR_TRUNC"); } ARR(a)->size = i; POP(3); GOPAIRUNIT; } case T_FPNEW: { CHKARG2NP; //printf("T_FPNEW\n"); void *xp = evalptr(x); //printf("T_FPNEW xp=%p\n", xp); GCCHECK(2); NODEPTR res = alloc_node(T_FORPTR); SETFORPTR(res, mkForPtrP(xp)); POP(2); GOPAIR(res); } case T_FPFIN: { CHKARG3NP; //printf("T_FPFIN\n"); struct forptr *xfp = evalforptr(y); //printf("T_FPFIN xfp=%p\n", xfp); HsFunPtr xp = evalfunptr(x); //printf("T_FPFIN yp=%p\n", yp); xfp->finalizer->final = xp; POP(3); GOPAIRUNIT; } case T_IO_GC: //printf("gc()\n"); CHKARG2NP; { int red = evalint(x); int oldred = want_gc_red; want_gc_red = red; gc(); want_gc_red = oldred; } POP(2); GOPAIRUNIT; case T_IO_STATS: { GCCHECK(4); CHKARG1; NODEPTR res = new_ap(new_ap(combPair, mkInt((uvalue_t)num_alloc)), mkInt((uvalue_t)(num_reductions - glob_slice))); GOPAIR(res); } case T_IO_FORK: { GCCHECK(3); CHKARG2; /* set x=io, y=ST, n */ struct mthread *mt = new_thread(new_ap(x, y)); /* copy the world */ mt->mt_mask = runq.mq_head->mt_mask; /* inherit masking state */ NODEPTR res = alloc_node(T_THID); THR(res) = mt; GOPAIR(res); } case T_IO_THID: { GCCHECK(2); CHKARG1; NODEPTR res = alloc_node(T_THID); THR(res) = runq.mq_head; /* head of the run queue is the current thread */ GOPAIR(res); } case T_IO_THROWTO: { CHKARG3NP; /* x=this, y=exn, z=ST */ check_thrown(true); /* check if we have a thrown exception */ struct mthread *mt = evalthid(x); throwto(mt, y); POP(3); GOPAIRUNIT; } case T_IO_YIELD: CHKARG1; yield(); GOPAIRUNIT; case T_IO_NEWMVAR: { GCCHECK(2); CHKARG1; struct mvar *mv = new_mvar(); NODEPTR res = alloc_node(T_MVAR); MVAR(res) = mv; GOPAIR(res); } case T_IO_TAKEMVAR: { CHKARG2NP; /* set x=mvar, y=ST */ check_thrown(true); /* check if we have a thrown exception */ NODEPTR res = take_mvar(false, evalmvar(x)); /* never returns if it blocks */ GCCHECKSAVE(res, 1); POP(2); GOPAIR(res); } case T_IO_READMVAR: { CHKARG2NP; check_thrown(true); /* check if we have a thrown exception */ NODEPTR res = read_mvar(false, evalmvar(x)); /* never returns if it blocks */ GCCHECKSAVE(res, 1); POP(2); GOPAIR(res); } case T_IO_PUTMVAR: { CHKARG3NP; /* set x=mvar, y=value, z=ST */ check_thrown(true); /* check if we have a thrown exception */ (void)put_mvar(false, evalmvar(x), y); /* never returns if it blocks */ POP(3); GOPAIRUNIT; } case T_IO_TRYTAKEMVAR: { CHKARG2NP; NODEPTR res = take_mvar(true, evalmvar(x)); GCCHECKSAVE(res, 2); if (res != NIL) res = new_ap(combJust, res); else res = combNothing; POP(2); GOPAIR(res); } case T_IO_TRYREADMVAR: { CHKARG2NP; NODEPTR res = read_mvar(true, evalmvar(x)); if (res != NIL) { GCCHECKSAVE(res, 2); res = new_ap(combJust, res); } else { res = combNothing; } POP(2); GOPAIR(res); } case T_IO_TRYPUTMVAR: { CHKARG3NP; NODEPTR res = put_mvar(true, evalmvar(x), y) ? combTrue : combFalse; GCCHECKSAVE(res, 1); POP(3); GOPAIR(res); } case T_IO_THREADDELAY: { CHKARG2NP; #if defined(CLOCK_INIT) check_thrown(true); /* check if we have a thrown exception */ if (runq.mq_head->mt_at == -1) { /* delay has already expired, so just return */ runq.mq_head->mt_at = 0; POP(2); GOPAIRUNIT; } else { thread_delay(evalint(x)); /* never returns */ } #else ERR("threadDelay: no clock"); #endif } case T_IO_THREADSTATUS: { CHKARG2NP; struct mthread *mt = evalthid(x); GCCHECK(2); POP(2); GOPAIR(mkInt(mt->mt_state)); } case T_IO_GETMASKINGSTATE: CHKARG1; /* x = ST */ GOPAIR(mkInt(runq.mq_head->mt_mask)); case T_IO_SETMASKINGSTATE: CHKARG2; /* x = level, y = ST */ runq.mq_head->mt_mask = evalint(x); GOPAIRUNIT; case T_CATCH: /* CATCH x y z --> CATCHR (x z) y z */ GCCHECK(3); CHKARG3; /* x=io, y=hdl, z=ST */ GOAP(new_ap(new_ap(combCATCHR, new_ap(x, z)), y), z); case T_CATCHR: { CHKARG3NP; /* x = (io st), y = hdl, z = st, n = (CATCHR (io st)) h */ struct handler *h = mmalloc(sizeof *h); h->hdl_old = cur_handler; cur_handler = h; stackptr_t ostack = stack_ptr;; /* old stack pointer */ enum mask_state omask = runq.mq_head->mt_mask; /* old mask */ if (setjmp(h->hdl_buf)) { /* An exception occurred: */ stack_ptr = ostack; runq.mq_head->mt_mask = mask_interruptible; /* evaluate with mask */ NODEPTR exn = h->hdl_exn; /* exception value */ cur_handler = h->hdl_old; /* reset handler */ FREE(h); GCCHECK(8); POP(3); /* * Run: * hdl exn `primBind` \ r -> * primSetMaskingState omask `primThen` * primReturn r * i.e., * primBind (hdl exn) (B' primThen (primSetMaskingState omask) primReturn) */ NODEPTR p = new_ap(combIOBIND, new_ap(y, exn)); NODEPTR q = new_ap(new_ap(new_ap(combBB, combIOTHEN), new_ap(combSETMASKINGSTATE, mkInt(omask))), combIORETURN); GOAP2(p, q, z); } else { /* Normal execution: */ x = evali(x); /* execute first argument */ /* No exception occurred */ cur_handler = h->hdl_old; /* restore old handler */ FREE(h); POP(3); GOIND(x); } } case T_THNUM: { CHECK(1); struct mthread *mt = evalthid(ARG(TOP(0))); POP(1); n = TOP(-1); SETINT(n, (uvalue_t)mt->mt_id); RET; } case T_DYNSYM: /* A dynamic FFI lookup */ CHECK(1); msg = evalstring(ARG(TOP(0))).string; GCCHECK(1); x = ffiNode(msg); FREE(msg); POP(1); n = TOP(-1); GOIND(x); #if WANT_TICK case T_TICK: xi = GETVALUE(n); CHKARG1; dotick(xi); GOIND(x); #endif default: ERR1("eval tag %s", TAGNAME(GETTAG(n))); } ret: if (stack_ptr != stk) { // In this case, n was an AP that got pushed and potentially // updated. uvalue_t xu, yu, ru; #if NEED_INT64 uint64_t x64u, y64u, r64u; #endif /* NEED_INT64 */ #if WANT_FLOAT32 flt32_t xf, yf, rf; #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 flt64_t xd, yd, rd; #endif /* WANT_FLOAT64 */ NODEPTR p; tag = GETTAG(TOP(0)); switch (tag) { case T_BININT2: n = ARG(TOP(1)); TOP(0) = combBININT1; goto top; case T_BININT1: /* First argument */ #if SANITY if (GETTAG(n) != T_INT) ERR("BININT 0"); #endif /* SANITY */ binint1: xu = (uvalue_t)GETVALUE(n); /* Second argument */ y = ARG(TOP(2)); while (GETTAG(y) == T_IND) y = GETINDIR(y); #if SANITY if (GETTAG(y) != T_INT) ERR("BININT 1"); #endif /* SANITY */ yu = (uvalue_t)GETVALUE(y); p = FUN(TOP(1)); POP(3); n = TOP(-1); binint: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto binint; case T_ADD: ru = xu + yu; break; case T_SUB: ru = xu - yu; break; case T_MUL: ru = xu * yu; break; case T_SUBR: ru = yu - xu; break; case T_QUOT: if (yu == 0) raise_rts(exn_dividebyzero); else ru = (uvalue_t)((value_t)xu / (value_t)yu); break; case T_REM: if (yu == 0) raise_rts(exn_dividebyzero); else ru = (uvalue_t)((value_t)xu % (value_t)yu); break; case T_UQUOT: if (yu == 0) raise_rts(exn_dividebyzero); else ru = xu / yu; break; case T_UREM: if (yu == 0) raise_rts(exn_dividebyzero); else ru = xu % yu; break; case T_AND: ru = xu & yu; break; case T_OR: ru = xu | yu; break; case T_XOR: ru = xu ^ yu; break; case T_SHL: ru = xu << yu; break; case T_SHR: ru = xu >> yu; break; case T_ASHR: ru = (uvalue_t)((value_t)xu >> yu); break; case T_EQ: GOIND(xu == yu ? combTrue : combFalse); case T_NE: GOIND(xu != yu ? combTrue : combFalse); case T_ULT: GOIND(xu < yu ? combTrue : combFalse); case T_ULE: GOIND(xu <= yu ? combTrue : combFalse); case T_UGT: GOIND(xu > yu ? combTrue : combFalse); case T_UGE: GOIND(xu >= yu ? combTrue : combFalse); case T_UCMP: GOIND(xu < yu ? combLT : xu > yu ? combGT : combEQ); case T_LT: GOIND((value_t)xu < (value_t)yu ? combTrue : combFalse); case T_LE: GOIND((value_t)xu <= (value_t)yu ? combTrue : combFalse); case T_GT: GOIND((value_t)xu > (value_t)yu ? combTrue : combFalse); case T_GE: GOIND((value_t)xu >= (value_t)yu ? combTrue : combFalse); case T_ICMP: GOIND((value_t)xu < (value_t)yu ? combLT : (value_t)xu > (value_t)yu ? combGT : combEQ); default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("BININT"); } SETINT(n, (value_t)ru); goto ret; case T_UNINT1: /* The argument */ #if SANITY if (GETTAG(n) != T_INT) ERR("UNINT 0"); #endif xu = (uvalue_t)GETVALUE(n); p = FUN(TOP(1)); POP(2); n = TOP(-1); unint: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto unint; case T_NEG: ru = -xu; break; case T_INV: ru = ~xu; break; case T_POPCOUNT: ru = POPCOUNT(xu); break; case T_CLZ: ru = CLZ(xu); break; case T_CTZ: ru = CTZ(xu); break; default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("UNINT"); } SETINT(n, (value_t)ru); goto ret; #if NEED_INT64 case T_BININT64_2: n = ARG(TOP(1)); TOP(0) = combBININT64_1; goto top; case T_BININT64_1: /* First argument */ #if SANITY if (GETTAG(n) != T_INT64) ERR("BININT64 0"); #endif /* SANITY */ binint64_1: x64u = (uint64_t)GETINT64VALUE(n); /* Second argument */ y = ARG(TOP(2)); while (GETTAG(y) == T_IND) y = GETINDIR(y); /* The second argument to the shift ops is an int, so use a hack for that */ if (GETTAG(y) == T_INT64) y64u = (uint64_t)GETINT64VALUE(y); else if (GETTAG(y) == T_INT) yu = (uvalue_t)GETVALUE(y); else ERR("BININT64 1"); p = FUN(TOP(1)); POP(3); n = TOP(-1); binint64: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto binint64; case T_ADD64: r64u = x64u + y64u; break; case T_SUB64: r64u = x64u - y64u; break; case T_MUL64: r64u = x64u * y64u; break; case T_SUBR64:r64u = y64u - x64u; break; case T_QUOT64:if (y64u == 0) raise_rts(exn_dividebyzero); else r64u = (uint64_t)((int64_t)x64u / (int64_t)y64u); break; case T_REM64: if (y64u == 0) raise_rts(exn_dividebyzero); else r64u = (uint64_t)((int64_t)x64u % (int64_t)y64u); break; case T_UQUOT64:if (y64u == 0) raise_rts(exn_dividebyzero); else r64u = x64u / y64u; break; case T_UREM64:if (y64u == 0) raise_rts(exn_dividebyzero); else r64u = x64u % y64u; break; case T_AND64: r64u = x64u & y64u; break; case T_OR64: r64u = x64u | y64u; break; case T_XOR64: r64u = x64u ^ y64u; break; case T_SHL64: r64u = x64u << yu; break; case T_SHR64: r64u = x64u >> yu; break; case T_ASHR64:r64u = (uint64_t)((int64_t)x64u >> yu); break; case T_EQ64: GOIND(x64u == y64u ? combTrue : combFalse); case T_NE64: GOIND(x64u != y64u ? combTrue : combFalse); case T_ULT64: GOIND(x64u < y64u ? combTrue : combFalse); case T_ULE64: GOIND(x64u <= y64u ? combTrue : combFalse); case T_UGT64: GOIND(x64u > y64u ? combTrue : combFalse); case T_UGE64: GOIND(x64u >= y64u ? combTrue : combFalse); case T_UCMP64:GOIND(x64u < y64u ? combLT : x64u > y64u ? combGT : combEQ); case T_LT64: GOIND((int64_t)x64u < (int64_t)y64u ? combTrue : combFalse); case T_LE64: GOIND((int64_t)x64u <= (int64_t)y64u ? combTrue : combFalse); case T_GT64: GOIND((int64_t)x64u > (int64_t)y64u ? combTrue : combFalse); case T_GE64: GOIND((int64_t)x64u >= (int64_t)y64u ? combTrue : combFalse); case T_ICMP64:GOIND((int64_t)x64u < (int64_t)y64u ? combLT : (int64_t)x64u > (int64_t)y64u ? combGT : combEQ); default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("BININT64"); } SETINT64(n, (int64_t)r64u); goto ret; case T_UNINT64_1: /* The argument */ #if SANITY if (GETTAG(n) != T_INT64) ERR("UNINT64 0"); #endif x64u = (uint64_t)GETINT64VALUE(n); p = FUN(TOP(1)); POP(2); n = TOP(-1); unint64: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto unint64; case T_NEG64: r64u = -x64u; break; case T_INV64: r64u = ~x64u; break; case T_POPCOUNT64: ru = POPCOUNT64(x64u); SETINT(n, (value_t)ru); goto ret; case T_CLZ64: ru = CLZ64(x64u); SETINT(n, (value_t)ru); goto ret; case T_CTZ64: ru = CTZ64(x64u); SETINT(n, (value_t)ru); goto ret; default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("UNINT64"); } SETINT64(n, (int64_t)r64u); goto ret; #endif /* NEED_INT64 */ #if WANT_FLOAT32 case T_BINFLT2: n = ARG(TOP(1)); TOP(0) = combBINFLT1; goto top; case T_BINFLT1: /* First argument */ #if SANITY if (GETTAG(n) != T_FLT32) ERR("BINDBL 0"); #endif /* SANITY */ xf = GETFLTVALUE(n); /* Second argument */ y = ARG(TOP(2)); while (GETTAG(y) == T_IND) y = GETINDIR(y); #if SANITY if (GETTAG(y) != T_FLT32) ERR("BINDBL 1"); #endif /* SANITY */ yf = GETFLTVALUE(y); p = FUN(TOP(1)); POP(3); n = TOP(-1); binflt: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto binflt; case T_FADD: rf = xf + yf; break; case T_FSUB: rf = xf - yf; break; case T_FMUL: rf = xf * yf; break; case T_FDIV: rf = xf / yf; break; case T_FEQ: GOIND(xf == yf ? combTrue : combFalse); case T_FNE: GOIND(xf != yf ? combTrue : combFalse); case T_FLT: GOIND(xf < yf ? combTrue : combFalse); case T_FLE: GOIND(xf <= yf ? combTrue : combFalse); case T_FGT: GOIND(xf > yf ? combTrue : combFalse); case T_FGE: GOIND(xf >= yf ? combTrue : combFalse); default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("BINFLT"); } SETFLT(n, rf); goto ret; case T_UNFLT1: /* The argument */ #if SANITY if (GETTAG(n) != T_FLT32) ERR("UNFLT 0"); #endif xf = GETFLTVALUE(n); p = FUN(TOP(1)); POP(2); n = TOP(-1); unflt: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto unflt; case T_FNEG: rf = -xf; break; default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("UNFLT"); } SETFLT(n, rf); goto ret; #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 case T_BINDBL2: n = ARG(TOP(1)); TOP(0) = combBINDBL1; goto top; case T_BINDBL1: /* First argument */ #if SANITY if (GETTAG(n) != T_DBL) ERR("BINDBL 0"); #endif /* SANITY */ xd = GETDBLVALUE(n); /* Second argument */ y = ARG(TOP(2)); while (GETTAG(y) == T_IND) y = GETINDIR(y); #if SANITY if (GETTAG(y) != T_DBL) ERR("BINDBL 1"); #endif /* SANITY */ yd = GETDBLVALUE(y); p = FUN(TOP(1)); POP(3); n = TOP(-1); bindbl: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto bindbl; case T_DADD: rd = xd + yd; break; case T_DSUB: rd = xd - yd; break; case T_DMUL: rd = xd * yd; break; case T_DDIV: rd = xd / yd; break; case T_DEQ: GOIND(xd == yd ? combTrue : combFalse); case T_DNE: GOIND(xd != yd ? combTrue : combFalse); case T_DLT: GOIND(xd < yd ? combTrue : combFalse); case T_DLE: GOIND(xd <= yd ? combTrue : combFalse); case T_DGT: GOIND(xd > yd ? combTrue : combFalse); case T_DGE: GOIND(xd >= yd ? combTrue : combFalse); default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("BINDBL"); } SETDBL(n, rd); goto ret; case T_UNDBL1: /* The argument */ #if SANITY if (GETTAG(n) != T_DBL) ERR("UNDBL 0"); #endif xd = GETDBLVALUE(n); p = FUN(TOP(1)); POP(2); n = TOP(-1); undbl: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto undbl; case T_DNEG: rd = -xd; break; default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("UNDBL"); } SETDBL(n, rd); goto ret; #endif /* WANT_FLOAT64 */ case T_BINBS2: n = ARG(TOP(1)); TOP(0) = combBINBS1; goto top; case T_BINBS1: /* First argument */ #if SANITY if (GETTAG(n) != T_FORPTR || FORPTR(n)->finalizer->fptype != FP_BSTR) ERR("BINBS 0"); #endif /* SANITY */ xbs = BSTR(n); /* Second argument */ y = ARG(TOP(2)); while (GETTAG(y) == T_IND) y = GETINDIR(y); #if SANITY if (GETTAG(y) != T_FORPTR || FORPTR(y)->finalizer->fptype != FP_BSTR) ERR("BINBS 1"); #endif /* SANITY */ ybs = BSTR(y); p = FUN(TOP(1)); POP(3); n = TOP(-1); binbs: switch (GETTAG(p)) { case T_IND: p = GETINDIR(p); goto binbs; case T_BSAPPEND: rbs = bsappend(xbs, ybs); break; case T_BSAPPENDDOT: rbs = bsappenddot(xbs, ybs); break; case T_BSEQ: GOIND(bscompare(xbs, ybs) == 0 ? combTrue : combFalse); case T_BSNE: GOIND(bscompare(xbs, ybs) != 0 ? combTrue : combFalse); case T_BSLT: GOIND(bscompare(xbs, ybs) < 0 ? combTrue : combFalse); case T_BSLE: GOIND(bscompare(xbs, ybs) <= 0 ? combTrue : combFalse); case T_BSGT: GOIND(bscompare(xbs, ybs) > 0 ? combTrue : combFalse); case T_BSGE: GOIND(bscompare(xbs, ybs) >= 0 ? combTrue : combFalse); case T_BSCMP: r = bscompare(xbs, ybs); GOIND(r < 0 ? combLT : r > 0 ? combGT : combEQ); default: //fprintf(stderr, "tag=%d\n", GETTAG(FUN(TOP(0)))); ERR("BINBS"); } SETBSTR(n, mkForPtrFree(rbs)); goto ret; default: stack_ptr = stk; n = TOP(-1); } } #if MAXSTACKDEPTH cur_c_stack = old_cur_c_stack; /* reset rather than counting down, in case of longjump */ #endif return n; } static char *progname = "?"; NORETURN void die_exn(NODEPTR exn) { /* No handler: * First convert the exception to a string by calling displaySomeException. * The display function compiles to combShowExn, so we need to build * (combShowExn exn) and evaluate it. */ NODEPTR x; char *msg; in_raise = true; if (GETTAG(exn) == T_INT) { /* This is the special hack for RTS generated exception, represented by a T_INT */ switch(GETVALUE(exn)) { case 0: msg = "stack overflow"; break; case 1: msg = "heap overflow"; break; case 2: msg = "thread killed"; break; case 3: msg = "user interrupt"; break; case 4: msg = "DivideByZero"; break; case 5: msg = "blocked MVar"; break; case 6: msg = "blocked STM"; break; default: msg = "unknown"; break; } } else { /* just overwrite the top stack element, we don't need it */ CLEARSTK(); GCCHECK(1); PUSH(new_ap(combShowExn, exn));/* TOP(0) = (combShowExn exn) */ x = evali(TOP(0)); /* evaluate it */ msg = evalstring(x).string; /* and convert to a C string */ POP(1); } #if WANT_STDIO /* A horrible hack until we get proper exceptions */ if (strcmp(msg, "ExitSuccess") == 0) { EXIT(0); } else { fprintf(stderr, "\n%s: uncaught exception: %s\n", progname, msg); EXIT(1); } #else /* WANT_STDIO */ ERR1("mhs error: %s", msg); #endif /* WANT_STDIO */ } #if WANT_ARGS heapoffs_t memsize(const char *p) { heapoffs_t n = atoi(p); while (isdigit(*p)) p++; switch (*p) { case 'k': case 'K': n *= 1000; break; case 'm': case 'M': n *= 1000000; break; case 'g': case 'G': n *= 1000000000; break; default: break; } return n; } #endif extern const uint8_t *combexpr; extern const int combexprlen; #if WANT_TICK int dump_ticks = 0; #endif NODEPTR mhs_init_args( #if WANT_ARGS int argc, char **argv, #endif #if WANT_STDIO char **outnamep, size_t *file_sizep #endif ) { NODEPTR prog; #if WANT_ARGS char *inname = 0; char **av; char **gargv; int gargc; int inrts; #endif #if 0 /* MINGW doesn't do buffering right */ setvbuf(stdout, NULL, _IOLBF, BUFSIZ); setvbuf(stderr, NULL, _IONBF, BUFSIZ); #endif #ifdef INITIALIZATION main_setup(); /* Do platform specific start-up. */ #endif #ifdef CLOCK_INIT CLOCK_INIT(); #endif #if WANT_SIGINT { (void)signal(SIGINT, handle_sigint); sigset_t set; sigemptyset(&set); sigaddset(&set, SIGINT); sigprocmask(SIG_UNBLOCK, &set, NULL); } #endif heap_size = HEAP_CELLS; /* number of heap cells */ stack_size = STACK_SIZE; /* number of stack slots */ #if WANT_ARGS progname = argv[0]; argc--, argv++; gargv = argv; for (av = argv, inrts = 0; argc--; argv++) { char *p = *argv; if (inrts) { if (strcmp(p, "-RTS") == 0) { inrts = 0; } else { if (strcmp(p, "-v") == 0) verbose++; #if WANT_TICK else if (strcmp(p, "-T") == 0) dump_ticks = 1; #endif else if (strncmp(p, "-H", 2) == 0) heap_size = memsize(&p[2]); else if (strncmp(p, "-K", 2) == 0) stack_size = memsize(&p[2]); else if (strncmp(p, "-r", 2) == 0) inname = &p[2]; #if WANT_STDIO else if (strncmp(p, "-o", 2) == 0) *outnamep = &p[2]; else if (strcmp(p, "-B") == 0) gcbell++; #endif /* WANT_STDIO */ else ERR("Usage: eval [+RTS [-v] [-B] [-T] [-Hheap-size] [-Kstack-size] [-rFILE] [-oFILE] -RTS] arg ..."); } } else { if (strcmp(p, "+RTS") == 0) { inrts = 1; } else { *av++ = p; } } } gargc = av - gargv; if (inname == 0) inname = "out.comb"; #endif init_nodes(); stack = mmalloc(sizeof(NODEPTR) * stack_size); CLEARSTK(); init_stableptr(); num_reductions = 0; #if WANT_ARGS /* Initialize an IORef (i.e., single element IOArray * to contain the list of program arguments. * The 0th element is the program name, and the rest * are the non RTS arguments. */ { NODEPTR n; /* No GC checks, the heap is empty. */ n = mkNil(); for(int i = gargc-1; i >= 0; i--) { n = mkCons(mkStringC(gargv[i]), n); } n = mkCons(mkStringC(progname), n); argarray = arr_alloc(1, n); /* An IORef contains a single element array */ argarray->permanent = true; /* never GC the arguments, because a T_IO_GETARGREF can reach argarray */ } #endif /* WANT_ARGS */ { /* Read the combinator code. */ BFILE *bf; if (combexpr) { /* The code is in memory, create a memore buffer BFILE */ bf = openb_rd_mem(combexpr, combexprlen); #if WANT_STDIO *file_sizep = combexprlen; #endif } else { #if WANT_STDIO /* Open a regular file */ FILE *f = fopen(inname, "r"); if (!f) ERR1("file not found %s", inname); fseek(f, 0, SEEK_END); *file_sizep = ftell(f); /* find its size */ rewind(f); bf = add_FILE(f); #else ERR("no stdio"); #endif } int c = getb(bf); #if WANT_BASE64 /* Compressed combinators start with a 'z', otherwise 'v' (for version) */ if (c != 'z' && c != 'v') { /* Neither z nor v, assume base64 encoded */ ungetb(c, bf); bf = add_base64_decoder(bf); c = getb(bf); } #endif if (c == 'z') { /* add LZ77 compressor transducer */ bf = add_lz77_decompressor(bf); } else { /* put it back, we need it */ ungetb(c, bf); } prog = parse_top(bf, xffe_table); closeb(bf); } /* GC unused stuff, nice for -o */ PUSH(prog); want_gc_red = 1; gc(); gc(); /* this finds some more GC reductions */ want_gc_red = 0; /* can be enabled, but it is rarely a win */ prog = POPTOP(); return prog; } void mhs_init(void) { char *args[2] = { "", 0 }; char *outname; size_t file_size; (void)mhs_init_args(1, args, &outname, &file_size); } int mhs_main(int argc, char **argv) { NODEPTR prog; char *outname = 0; size_t file_size = 0; #if WANT_KPERF counter_t instrs; #endif /* WANT_KPERF */ prog = mhs_init_args(argc, argv, &outname, &file_size); #if WANT_STDIO heapoffs_t start_size = num_marked; if (outname) { /* Save GCed file (smaller), and exit. */ FILE *out = fopen(outname, "w"); if (!out) ERR1("cannot open output file %s", outname); struct BFILE *bf = add_FILE(out); printb(bf, prog, true); closeb(bf); EXIT(0); } if (verbose > 2) { pp(stdout, prog); } #endif run_time -= GETTIMEMILLI(); #if 0 topnode = &prog; #endif #if WANT_KPERF if (!start_kperf()) { // ERR("kperf init failed"); #if WANT_STDIO fprintf(stderr, "start_kperf() failed, ignored\n"); #endif } #endif /* WANT_KPERF */ start_exec(prog); /* Flush standard handles in case there is some BFILE buffering */ flushb((BFILE*)FORPTR(comb_stdout)->payload.string); flushb((BFILE*)FORPTR(comb_stderr)->payload.string); gc(); /* Run finalizers */ #if WANT_KPERF instrs = end_kperf(); #endif /* WANT_KPERF */ run_time += GETTIMEMILLI(); #if WANT_STDIO if (verbose) { if (verbose > 1) { PRINT("node size=%"PRIheap", heap size bytes=%"PRIheap"\n", (heapoffs_t)NODE_SIZE, heap_size * NODE_SIZE); } setlocale(LC_NUMERIC, "en_US"); /* Make %' work on platforms that support it */ PRINT("%"PCOMMA"15"PRIheap" combinator file size\n", (heapoffs_t)file_size); PRINT("%"PCOMMA"15"PRIheap" cells at start\n", start_size); PRINT("%"PCOMMA"15"PRIheap" cells heap size (%"PCOMMA""PRIheap" bytes)\n", heap_size, heap_size * NODE_SIZE); PRINT("%"PCOMMA"15"PRIcounter" cells allocated (%"PCOMMA".1f Mbyte/s)\n", num_alloc, num_alloc * NODE_SIZE / ((double)run_time / 1000) / 1000000); PRINT("%"PCOMMA"15"PRIcounter" GCs\n", num_gc); PRINT("%"PCOMMA"15"PRIcounter" max cells used\n", max_num_marked); PRINT("%"PCOMMA"15"PRIcounter" reductions (%"PCOMMA".1f Mred/s)\n", num_reductions, num_reductions / ((double)run_time / 1000) / 1000000); PRINT("%"PCOMMA"15"PRIcounter" yields (%"PCOMMA""PRIcounter" resched)\n", num_yield, num_resched); PRINT("%"PCOMMA"15"PRIcounter" array alloc\n", num_arr_alloc); PRINT("%"PCOMMA"15"PRIcounter" array free\n", num_arr_free); PRINT("%"PCOMMA"15"PRIcounter" foreign alloc\n", num_fin_alloc); PRINT("%"PCOMMA"15"PRIcounter" foreign free\n", num_fin_free); PRINT("%"PCOMMA"15"PRIcounter" bytestring alloc (max %"PCOMMA""PRIcounter")\n", num_bs_alloc, num_bs_alloc_max); PRINT("%"PCOMMA"15"PRIcounter" bytestring alloc bytes (max %"PCOMMA""PRIcounter")\n", num_bs_bytes, num_bs_inuse_max); PRINT("%"PCOMMA"15"PRIcounter" bytestring free\n", num_bs_free); PRINT("%"PCOMMA"15"PRIcounter" thread create\n", num_thread_create-1); PRINT("%"PCOMMA"15"PRIcounter" thread reap\n", num_thread_reap); PRINT("%"PCOMMA"15"PRIcounter" stableptr alloc\n", num_stable_alloc); PRINT("%"PCOMMA"15"PRIcounter" stableptr free\n", num_stable_free); PRINT("%"PCOMMA"15"PRIcounter" weakptr alloc\n", num_new_weak); PRINT("%"PCOMMA"15"PRIcounter" weakptr free\n", num_gc_weak); #if MAXSTACKDEPTH PRINT("%"PCOMMA"15d max stack depth\n", (int)max_stack_depth); PRINT("%"PCOMMA"15d max C stack depth\n", (int)max_c_stack); #endif // PRINT("%"PCOMMA"15d avg gc stack depth\n", (int)(gc_tot / num_gc)); // PRINT("%"PCOMMA"15"PRIcounter" max mark depth\n", max_mark_depth); PRINT("%15.2fs total expired time\n", (double)run_time / 1000); PRINT("%15.2fs gc expired time = %3.1f%% (%.2fs mark + %.2fs scan)\n", (double)(gc_mark_time + gc_scan_time) / 1000, (double)(gc_mark_time + gc_scan_time) / (double)run_time * 100, (double)gc_mark_time / 1000, (double)gc_scan_time / 1000); #if WANT_KPERF if (instrs > 0) { PRINT("%"PCOMMA"15"PRIcounter" instructions (%.1f instr/red)\n", instrs, (double)instrs / (double)num_reductions); } #endif /* WANT_KPERF */ #if GCRED PRINT(" GC reductions A=%"PRIcounter", K=%"PRIcounter", I=%"PRIcounter", int=%"PRIcounter", flip=%"PRIcounter"," " BI=%"PRIcounter", BxI=%"PRIcounter", C'BxI=%"PRIcounter", CC=%"PRIcounter", C'I=%"PRIcounter", C'BBCP=%"PRIcounter"\n", red_a, red_k, red_i, red_int, red_flip, red_bi, red_bxi, red_ccbi, red_cc, red_cci, red_ccbbcp); PRINT(" special reductions B'=%"PRIcounter" K4=%"PRIcounter" K3=%"PRIcounter" K2=%"PRIcounter" C'B=%"PRIcounter", Z=%"PRIcounter", R=%"PRIcounter"\n", red_bb, red_k4, red_k3, red_k2, red_ccb, red_z, red_r); #endif } #endif /* WANT_STDIO */ #if WANT_TICK if (dump_ticks) { dump_tick_table(stdout); } #endif #ifdef TEARDOWN main_teardown(); /* do some platform specific teardown */ #endif EXIT(0); } #if WANT_MD5 #include "md5.c" #endif /* WANT_MD5 */ #if WANT_LZ77 #include "lz77.c" #endif /***************************/ /* Foreign export helpers */ void ffe_push(NODEPTR n) { PUSH(n); } void ffe_pop(void) { POP(1); } /* Allocate a new node (will be overwritten) */ stackptr_t ffe_alloc(void) { PUSH(alloc_node(T_DBL)); return stack_ptr; } void ffe_apply(void) { NODEPTR arg = POPTOP(); NODEPTR fun = POPTOP(); PUSH(new_ap(fun, arg)); } /* For stand-alone exported functions this is called with the threading inactive. * On the other hand, if a 'foreign import' calls back to a 'foreign export' the * threading is alread running. */ /* XXX This is not quite right. The surrounding mhs_to_xxx should be in the thread. */ stackptr_t ffe_eval(void) { if (main_thread) { /* threading active, run on current stack */ (void)evali(TOP(0)); } else { /* start up the threading to evaluate the node */ start_exec(TOP(0)); } /* The mhs_to_xxx functions bizarrely return the ARG(TOP(n+1)) value. * The wrapper will call with n=-1, so we need to put the result at ARG(TOP(0)) */ TOP(0) = new_ap(combI, TOP(0)); return stack_ptr; } stackptr_t ffe_exec(void) { NODEPTR n = POPTOP(); PUSH(new_ap(combPERFORMIO, n)); return ffe_eval(); } /* apply_sp :: StablePtr (Ptr a -> IO (Ptr b)) -> Ptr a -> IO (Ptr b) */ void * apply_sp(uvalue_t sp, void *arg) { GCCHECK(3); NODEPTR f = deref_stableptr(sp); NODEPTR a = alloc_node(T_PTR); PTR(a) = arg; PUSH(new_ap(combPERFORMIO, new_ap(f, a))); void *r = evalptr(TOP(0)); POP(1); return r; } /*********************/ /* FFI adapters */ #define MHS_FROM(name, set, type) \ from_t \ name(stackptr_t stk, int n, type x) \ { \ NODEPTR r = TOP(0); /* The pre-allocated cell for the result, */ \ set(r, x); /* Put result in pre-allocated cell. */ \ return n; /* return arity */ \ } #if WANT_FLOAT64 MHS_FROM(mhs_from_Double, SETDBL, flt64_t); #endif #if WANT_FLOAT32 MHS_FROM(mhs_from_Float, SETFLT, flt32_t); #endif MHS_FROM(mhs_from_Int, SETINT, value_t); MHS_FROM(mhs_from_Word, SETINT, uvalue_t); MHS_FROM(mhs_from_Word8, SETINT, uvalue_t); MHS_FROM(mhs_from_Ptr, SETPTR, void*); MHS_FROM(mhs_from_ForPtr, SETFORPTR, struct forptr *); MHS_FROM(mhs_from_FunPtr, SETFUNPTR, HsFunPtr); MHS_FROM(mhs_from_CChar, SETINT, char); MHS_FROM(mhs_from_CSChar, SETINT, signed char); MHS_FROM(mhs_from_CUChar, SETINT, unsigned char); MHS_FROM(mhs_from_CShort, SETINT, short); MHS_FROM(mhs_from_CUShort, SETINT, unsigned short); MHS_FROM(mhs_from_CInt, SETINT, int); MHS_FROM(mhs_from_CUInt, SETINT, unsigned int); MHS_FROM(mhs_from_CLong, SETINT, long); MHS_FROM(mhs_from_CULong, SETINT, unsigned long); MHS_FROM(mhs_from_CLLong, SETINT, long long); MHS_FROM(mhs_from_CULLong, SETINT, unsigned long long); MHS_FROM(mhs_from_CSize, SETINT, size_t); #if WANT_TIME MHS_FROM(mhs_from_CTime, SETINT, time_t); #endif // MHS_FROM(mhs_from_CSSize, SETINT, ssize_t); MHS_FROM(mhs_from_CIntPtr, SETINT, intptr_t); MHS_FROM(mhs_from_CUIntPtr, SETINT, uintptr_t); from_t mhs_from_Unit(stackptr_t stk, int n) { POP(1); /* return value cell */ PUSH(combUnit); /* push unit instead */ return n; } #define MHS_TO(name, eval, type) \ type name(stackptr_t stk, int n) \ { \ return eval(ARG(TOP(n+1))); /* The stack has a reserved cell on top of the arguments */ \ } #if WANT_FLOAT32 MHS_TO(mhs_to_Float, evalflt, flt32_t); #endif #if WANT_FLOAT64 MHS_TO(mhs_to_Double, evaldbl, flt64_t); #endif MHS_TO(mhs_to_Int, evalint, value_t); MHS_TO(mhs_to_Word, evalint, uvalue_t); MHS_TO(mhs_to_Word8, evalint, uint8_t); MHS_TO(mhs_to_Ptr, evalptr, void*); MHS_TO(mhs_to_FunPtr, evalfunptr, HsFunPtr); MHS_TO(mhs_to_CChar, evalint, char); MHS_TO(mhs_to_CSChar, evalint, signed char); MHS_TO(mhs_to_CUChar, evalint, unsigned char); MHS_TO(mhs_to_CShort, evalint, short); MHS_TO(mhs_to_CUShort, evalint, unsigned short); MHS_TO(mhs_to_CInt, evalint, int); MHS_TO(mhs_to_CUInt, evalint, unsigned int); MHS_TO(mhs_to_CLong, evalint, long); MHS_TO(mhs_to_CULong, evalint, unsigned long); MHS_TO(mhs_to_CLLong, evalint, long long); MHS_TO(mhs_to_CULLong, evalint, unsigned long long); MHS_TO(mhs_to_CSize, evalint, size_t); #if WANT_TIME MHS_TO(mhs_to_CTime, evalint, time_t); #endif // MHS_TO(mhs_to_CSSize, evalint, ssize_t); MHS_TO(mhs_to_CIntPtr, evalint, intptr_t); MHS_TO(mhs_to_CUIntPtr, evalint, uintptr_t); /* The rest of this file was generated by the compiler, with some minor edits with #if. */ from_t mhs_GETRAW(int s) { return mhs_from_Int(s, 0, GETRAW()); } from_t mhs_GETTIMEMILLI(int s) { return mhs_from_Int(s, 0, GETTIMEMILLI()); } #if WANT_MATH #if WANT_FLOAT64 from_t mhs_acos(int s) { return mhs_from_Double(s, 1, acos(mhs_to_Double(s, 0))); } from_t mhs_asin(int s) { return mhs_from_Double(s, 1, asin(mhs_to_Double(s, 0))); } from_t mhs_atan(int s) { return mhs_from_Double(s, 1, atan(mhs_to_Double(s, 0))); } from_t mhs_atan2(int s) { return mhs_from_Double(s, 2, atan2(mhs_to_Double(s, 0), mhs_to_Double(s, 1))); } from_t mhs_cos(int s) { return mhs_from_Double(s, 1, cos(mhs_to_Double(s, 0))); } from_t mhs_exp(int s) { return mhs_from_Double(s, 1, exp(mhs_to_Double(s, 0))); } from_t mhs_log(int s) { return mhs_from_Double(s, 1, log(mhs_to_Double(s, 0))); } from_t mhs_sin(int s) { return mhs_from_Double(s, 1, sin(mhs_to_Double(s, 0))); } from_t mhs_sqrt(int s) { return mhs_from_Double(s, 1, sqrt(mhs_to_Double(s, 0))); } from_t mhs_tan(int s) { return mhs_from_Double(s, 1, tan(mhs_to_Double(s, 0))); } from_t mhs_scalbn(int s) { return mhs_from_Double(s, 2, scalbn(mhs_to_Double(s, 0), mhs_to_Int(s, 1))); } #endif /* WANT_FLOAT64 */ #if WANT_FLOAT32 from_t mhs_acosf(int s) { return mhs_from_Float(s, 1, acosf(mhs_to_Float(s, 0))); } from_t mhs_asinf(int s) { return mhs_from_Float(s, 1, asinf(mhs_to_Float(s, 0))); } from_t mhs_atanf(int s) { return mhs_from_Float(s, 1, atanf(mhs_to_Float(s, 0))); } from_t mhs_atan2f(int s) { return mhs_from_Float(s, 2, atan2f(mhs_to_Float(s, 0), mhs_to_Float(s, 1))); } from_t mhs_cosf(int s) { return mhs_from_Float(s, 1, cosf(mhs_to_Float(s, 0))); } from_t mhs_expf(int s) { return mhs_from_Float(s, 1, expf(mhs_to_Float(s, 0))); } from_t mhs_logf(int s) { return mhs_from_Float(s, 1, logf(mhs_to_Float(s, 0))); } from_t mhs_sinf(int s) { return mhs_from_Float(s, 1, sinf(mhs_to_Float(s, 0))); } from_t mhs_sqrtf(int s) { return mhs_from_Float(s, 1, sqrtf(mhs_to_Float(s, 0))); } from_t mhs_tanf(int s) { return mhs_from_Float(s, 1, tanf(mhs_to_Float(s, 0))); } from_t mhs_scalbnf(int s) { return mhs_from_Float(s, 2, scalbnf(mhs_to_Float(s, 0), mhs_to_Int(s, 1))); } #endif /* WANT_FLOAT32 */ #endif /* WANT_MATH */ #if defined(__EMSCRIPTEN__) from_t mhs_js_debug(int s) { EM_ASM({ console.log(UTF8ToString($0)) }, mhs_to_Ptr(s, 0)); return mhs_from_Unit(s, 1); } from_t mhs_js_eval_run(int s) { EM_ASM({ eval(UTF8ToString($0)) }, mhs_to_Ptr(s, 0)); return mhs_from_Unit(s, 1); } from_t mhs_js_eval_call(int s) { return mhs_from_Ptr(s, 1, EM_ASM_PTR({ return stringToNewUTF8(JSON.stringify(eval(UTF8ToString($0)))) }, mhs_to_Ptr(s, 0))); } from_t mhs_js_set_haskellCallback(int s) { EM_ASM({ _haskellCallback = $0 }, mhs_to_Int(s, 0)); return mhs_from_Unit(s, 1); } #endif #if WANT_STDIO from_t mhs_add_FILE(int s) { return mhs_from_Ptr(s, 1, add_FILE(mhs_to_Ptr(s, 0))); } from_t mhs_putchar(int s) { putchar(mhs_to_Int(s, 0)); return mhs_from_Unit(s, 1); } /* for debugging */ from_t mhs_fopen(int s) { return mhs_from_Ptr(s, 2, fopen(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1))); } from_t mhs_system(int s) { return mhs_from_Int(s, 1, system(mhs_to_Ptr(s, 0))); } from_t mhs_tmpname(int s) { return mhs_from_Ptr(s, 2, TMPNAME(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1))); } from_t mhs_unlink(int s) { return mhs_from_Int(s, 1, unlink(mhs_to_Ptr(s, 0))); } #endif /* WANT_STDIO */ #if WANT_FD from_t mhs_add_fd(int s) { return mhs_from_Ptr(s, 1, add_fd(mhs_to_Int(s, 0))); } from_t mhs_open(int s) { return mhs_from_Int(s, 3, open(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1), mhs_to_Int(s, 2))); } #endif /* WANT_FD */ #if WANT_BUF from_t mhs_add_buf(int s) { return mhs_from_Ptr(s, 2, add_buf(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1))); } #endif /* WANT_BUF */ #if WANT_CRLF from_t mhs_add_crlf(int s) { return mhs_from_Ptr(s, 1, add_crlf(mhs_to_Ptr(s, 0))); } #endif /* WANT_CRLF */ #if WANT_UTF8 from_t mhs_add_utf8(int s) { return mhs_from_Ptr(s, 1, add_utf8(mhs_to_Ptr(s, 0))); } #endif /* WANT_UTF8 */ #if WANT_BASE64 from_t mhs_add_base64_encoder(int s) { return mhs_from_Ptr(s, 1, add_base64_encoder(mhs_to_Ptr(s, 0))); } from_t mhs_add_base64_decoder(int s) { return mhs_from_Ptr(s, 1, add_base64_decoder(mhs_to_Ptr(s, 0))); } #endif /* WANT_BASE64 */ from_t mhs_closeb(int s) { closeb(mhs_to_Ptr(s, 0)); return mhs_from_Unit(s, 1); } from_t mhs_addr_closeb(int s) { return mhs_from_FunPtr(s, 0, (HsFunPtr)&closeb); } from_t mhs_flushb(int s) { flushb(mhs_to_Ptr(s, 0)); return mhs_from_Unit(s, 1); } from_t mhs_getb(int s) { return mhs_from_Int(s, 1, getb(mhs_to_Ptr(s, 0))); } from_t mhs_putb(int s) { putb(mhs_to_Int(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_ungetb(int s) { ungetb(mhs_to_Int(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_openwrmem(int s) { return mhs_from_Ptr(s, 0, openb_wr_mem()); } from_t mhs_openrdmem(int s) { return mhs_from_Ptr(s, 2, openb_rd_mem(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1))); } from_t mhs_getmem(int s) { get_mem(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_readb(int s) { return mhs_from_Int(s, 3, readb(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1), mhs_to_Ptr(s, 2))); } from_t mhs_writeb(int s) { return mhs_from_Int(s, 3, writeb(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1), mhs_to_Ptr(s, 2))); } #if WANT_MD5 from_t mhs_md5Array(int s) { md5Array(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Int(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_md5BFILE(int s) { md5BFILE(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_md5String(int s) { md5String(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WANT_MD5 */ #if WANT_LZ77 from_t mhs_add_lz77_compressor(int s) { return mhs_from_Ptr(s, 1, add_lz77_compressor(mhs_to_Ptr(s, 0))); } from_t mhs_add_lz77_decompressor(int s) { return mhs_from_Ptr(s, 1, add_lz77_decompressor(mhs_to_Ptr(s, 0))); } from_t mhs_lz77c(int s) { return mhs_from_CSize(s, 3, lz77c(mhs_to_Ptr(s, 0), mhs_to_CSize(s, 1), mhs_to_Ptr(s, 2))); } #endif /* WANT_LZ77 */ #if WANT_RLE from_t mhs_add_rle_compressor(int s) { return mhs_from_Ptr(s, 1, add_rle_compressor(mhs_to_Ptr(s, 0))); } from_t mhs_add_rle_decompressor(int s) { return mhs_from_Ptr(s, 1, add_rle_decompressor(mhs_to_Ptr(s, 0))); } #endif /* WANT_RLE */ #if WANT_BWT from_t mhs_add_bwt_compressor(int s) { return mhs_from_Ptr(s, 1, add_bwt_compressor(mhs_to_Ptr(s, 0))); } from_t mhs_add_bwt_decompressor(int s) { return mhs_from_Ptr(s, 1, add_bwt_decompressor(mhs_to_Ptr(s, 0))); } #endif /* WANT_BWT */ from_t mhs_calloc(int s) { return mhs_from_Ptr(s, 2, calloc(mhs_to_CSize(s, 0), mhs_to_CSize(s, 1))); } from_t mhs_realloc(int s) { return mhs_from_Ptr(s, 2, realloc(mhs_to_Ptr(s, 0), mhs_to_CSize(s, 1))); } from_t mhs_free(int s) { free(mhs_to_Ptr(s, 0)); return mhs_from_Unit(s, 1); } from_t mhs_addr_free(int s) { return mhs_from_FunPtr(s, 0, (HsFunPtr)&FREE); } from_t mhs_getenv(int s) { return mhs_from_Ptr(s, 1, getenv(mhs_to_Ptr(s, 0))); } from_t mhs_environ(int s) { return mhs_from_Ptr(s, 0, environ); } from_t mhs_iswindows(int s) { return mhs_from_Int(s, 0, iswindows()); } from_t mhs_ismacos(int s) { return mhs_from_Int(s, 0, ismacos()); } from_t mhs_islinux(int s) { return mhs_from_Int(s, 0, islinux()); } from_t mhs_malloc(int s) { return mhs_from_Ptr(s, 1, MALLOC(mhs_to_CSize(s, 0))); } from_t mhs_memcpy(int s) { memcpy(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_CSize(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_strlen(int s) { return mhs_from_CSize(s, 1, strlen(mhs_to_Ptr(s, 0))); } from_t mhs_strcpy(int s) { strcpy(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_memmove(int s) { memmove(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_CSize(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_peekPtr(int s) { return mhs_from_Ptr(s, 1, peekPtr(mhs_to_Ptr(s, 0))); } from_t mhs_peekWord(int s) { return mhs_from_Word(s, 1, peekWord(mhs_to_Ptr(s, 0))); } from_t mhs_pokePtr(int s) { pokePtr(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_pokeWord(int s) { pokeWord(mhs_to_Ptr(s, 0), mhs_to_Word(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_uint8(int s) { return mhs_from_Word(s, 1, peek_uint8(mhs_to_Ptr(s, 0))); } from_t mhs_poke_uint8(int s) { poke_uint8(mhs_to_Ptr(s, 0), mhs_to_Word(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_uint16(int s) { return mhs_from_Word(s, 1, peek_uint16(mhs_to_Ptr(s, 0))); } from_t mhs_poke_uint16(int s) { poke_uint16(mhs_to_Ptr(s, 0), mhs_to_Word(s, 1)); return mhs_from_Unit(s, 2); } #if WORD_SIZE >= 32 from_t mhs_peek_uint32(int s) { return mhs_from_Word(s, 1, peek_uint32(mhs_to_Ptr(s, 0))); } from_t mhs_poke_uint32(int s) { poke_uint32(mhs_to_Ptr(s, 0), mhs_to_Word(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WORD_SIZE */ #if WORD_SIZE >= 64 from_t mhs_peek_uint64(int s) { return mhs_from_Word(s, 1, peek_uint64(mhs_to_Ptr(s, 0))); } from_t mhs_poke_uint64(int s) { poke_uint64(mhs_to_Ptr(s, 0), mhs_to_Word(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WORD_SIZE */ from_t mhs_peek_int8(int s) { return mhs_from_Int(s, 1, peek_int8(mhs_to_Ptr(s, 0))); } from_t mhs_poke_int8(int s) { poke_int8(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_int16(int s) { return mhs_from_Int(s, 1, peek_int16(mhs_to_Ptr(s, 0))); } from_t mhs_poke_int16(int s) { poke_int16(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1)); return mhs_from_Unit(s, 2); } #if WORD_SIZE >= 32 from_t mhs_peek_int32(int s) { return mhs_from_Int(s, 1, peek_int32(mhs_to_Ptr(s, 0))); } from_t mhs_poke_int32(int s) { poke_int32(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WORD_SIZE */ #if WORD_SIZE >= 64 from_t mhs_peek_int64(int s) { return mhs_from_Int(s, 1, peek_int64(mhs_to_Ptr(s, 0))); } from_t mhs_poke_int64(int s) { poke_int64(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WORD_SIZE */ from_t mhs_peek_char(int s) { return mhs_from_CChar(s, 1, peek_char(mhs_to_Ptr(s, 0))); } from_t mhs_poke_char(int s) { poke_char(mhs_to_Ptr(s, 0), mhs_to_CChar(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_schar(int s) { return mhs_from_CSChar(s, 1, peek_schar(mhs_to_Ptr(s, 0))); } from_t mhs_poke_schar(int s) { poke_schar(mhs_to_Ptr(s, 0), mhs_to_CSChar(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_uchar(int s) { return mhs_from_CUChar(s, 1, peek_uchar(mhs_to_Ptr(s, 0))); } from_t mhs_poke_uchar(int s) { poke_uchar(mhs_to_Ptr(s, 0), mhs_to_CUChar(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_short(int s) { return mhs_from_CShort(s, 1, peek_short(mhs_to_Ptr(s, 0))); } from_t mhs_poke_short(int s) { poke_short(mhs_to_Ptr(s, 0), mhs_to_CShort(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_ushort(int s) { return mhs_from_CUShort(s, 1, peek_ushort(mhs_to_Ptr(s, 0))); } from_t mhs_poke_ushort(int s) { poke_ushort(mhs_to_Ptr(s, 0), mhs_to_CUShort(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_int(int s) { return mhs_from_CInt(s, 1, peek_int(mhs_to_Ptr(s, 0))); } from_t mhs_poke_int(int s) { poke_int(mhs_to_Ptr(s, 0), mhs_to_CInt(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_uint(int s) { return mhs_from_CUInt(s, 1, peek_uint(mhs_to_Ptr(s, 0))); } from_t mhs_poke_uint(int s) { poke_uint(mhs_to_Ptr(s, 0), mhs_to_CUInt(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_long(int s) { return mhs_from_CLong(s, 1, peek_long(mhs_to_Ptr(s, 0))); } from_t mhs_poke_long(int s) { poke_long(mhs_to_Ptr(s, 0), mhs_to_CLong(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_ulong(int s) { return mhs_from_CULong(s, 1, peek_ulong(mhs_to_Ptr(s, 0))); } from_t mhs_poke_ulong(int s) { poke_ulong(mhs_to_Ptr(s, 0), mhs_to_CULong(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_llong(int s) { return mhs_from_CLLong(s, 1, peek_llong(mhs_to_Ptr(s, 0))); } from_t mhs_poke_llong(int s) { poke_llong(mhs_to_Ptr(s, 0), mhs_to_CLLong(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_ullong(int s) { return mhs_from_CULLong(s, 1, peek_ullong(mhs_to_Ptr(s, 0))); } from_t mhs_poke_ullong(int s) { poke_ullong(mhs_to_Ptr(s, 0), mhs_to_CULLong(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_peek_size_t(int s) { return mhs_from_CSize(s, 1, peek_size_t(mhs_to_Ptr(s, 0))); } from_t mhs_poke_size_t(int s) { poke_size_t(mhs_to_Ptr(s, 0), mhs_to_CSize(s, 1)); return mhs_from_Unit(s, 2); } #if WANT_FLOAT32 from_t mhs_peek_flt32(int s) { return mhs_from_Float(s, 1, peek_flt32(mhs_to_Ptr(s, 0))); } from_t mhs_poke_flt32(int s) { poke_flt32(mhs_to_Ptr(s, 0), mhs_to_Float(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WANT_FLOAT32 */ #if WANT_FLOAT64 from_t mhs_peek_flt64(int s) { return mhs_from_Double(s, 1, peek_flt64(mhs_to_Ptr(s, 0))); } from_t mhs_poke_flt64(int s) { poke_flt64(mhs_to_Ptr(s, 0), mhs_to_Double(s, 1)); return mhs_from_Unit(s, 2); } #endif /* WANT_FLOAT64 */ from_t mhs_sizeof_char(int s) { return mhs_from_Int(s, 0, sizeof(char)); } from_t mhs_sizeof_short(int s) { return mhs_from_Int(s, 0, sizeof(short)); } from_t mhs_sizeof_int(int s) { return mhs_from_Int(s, 0, sizeof(int)); } from_t mhs_sizeof_llong(int s) { return mhs_from_Int(s, 0, sizeof(long long)); } from_t mhs_sizeof_long(int s) { return mhs_from_Int(s, 0, sizeof(long)); } from_t mhs_sizeof_size_t(int s) { return mhs_from_Int(s, 0, sizeof(size_t)); } #if WANT_DIR from_t mhs_closedir(int s) { return mhs_from_Int(s, 1, closedir(mhs_to_Ptr(s, 0))); } from_t mhs_opendir(int s) { return mhs_from_Ptr(s, 1, opendir(mhs_to_Ptr(s, 0))); } from_t mhs_readdir(int s) { return mhs_from_Ptr(s, 1, readdir(mhs_to_Ptr(s, 0))); } from_t mhs_c_d_name(int s) { return mhs_from_Ptr(s, 1, ((struct dirent *)(mhs_to_Ptr(s, 0)))->d_name); } from_t mhs_chdir(int s) { return mhs_from_Int(s, 1, chdir(mhs_to_Ptr(s, 0))); } from_t mhs_mkdir(int s) { return mhs_from_Int(s, 2, mkdir(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1))); } from_t mhs_getcwd(int s) { return mhs_from_Ptr(s, 2, getcwd(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1))); } #endif /* WANT_DIR */ from_t mhs_getcpu(int s) { GETCPUTIME(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } /* Use this to detect if we have (and want) GMP or not. */ from_t mhs_want_gmp(int s) { return mhs_from_Int(s, 0, WANT_GMP); } #if WANT_GMP void free_mpz(void *p) { /* printf("free_mpz %p\n", p);*/ mpz_clear(p); /* free any extra storage */ FREE(p); /* and free the mpz itself */ } /* Allocate an initialize a GMP integer */ struct forptr * new_mpz(void) { #if 0 { static int done = 0; if (!done) { printf("GMP\n"); done = 1; } } #endif mpz_ptr p = mmalloc(sizeof(*p)); mpz_init(p); struct forptr *fp = mkForPtrP(p); fp->finalizer->final = (HsFunPtr)free_mpz; fp->finalizer->fptype = FP_MPZ; /* printf("new_mpz %p %p\n", p, fp); */ return fp; } intptr_t mpz_get_si_(mpz_t op) { intptr_t r = mpz_get_ui(op); if (mpz_sgn(op) < 0) { r = -r; } return r; } #if 0 void print_mpz(mpz_ptr p) { mpz_out_str(stdout, 10, p); } #endif #if NEED_INT64 /* GMP lacks 64 bit support on 32 bit platforms */ void mpz_init_set_si64(mpz_t rop, int64_t op) { if (op >= 0) { mpz_init_set_ui64(rop, op); } else { mpz_init_set_ui64(rop, -op); mpz_neg(rop, rop); } } void mpz_init_set_ui64(mpz_t rop, uint64_t op) { mpz_init_set_ui(rop, op >> 32); mpz_mul_2exp(rop, rop, 32); mpz_add_ui(rop, rop, op & 0xffffffff); } int64_t mpz_get_si64(mpz_t op) { mpz_t t; mpz_init_set(t, op); mpz_tdiv_q_2exp(t, t, 32); uint64_t hi = mpz_get_ui(t); uint64_t lo = mpz_get_ui(op); mpz_clear(t); uint64_t r = (hi << 32) | lo; if (mpz_sgn(op) < 0) { r = -r; } return r; } #endif /* NEED_INT64 */ #if WORD_SIZE == 64 #define mpz_init_set_ui64 mpz_init_set_ui #define mpz_init_set_si64 mpz_init_set_si #define mpz_get_si64 mpz_get_si_ #define mhs_to_Int64 mhs_to_Int #define mhs_to_Word64 mhs_to_Word #define mhs_from_Int64 mhs_from_Int #define mhs_from_Word64 mhs_from_Word #endif from_t mhs_new_mpz(int s) { return mhs_from_ForPtr(s, 0, new_mpz()); } /* Stubs for GMP functions */ from_t mhs_mpz_abs(int s) { mpz_abs(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_mpz_add(int s) { mpz_add(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_and(int s) { mpz_and(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_cmp(int s) { return mhs_from_Int(s, 2, mpz_cmp(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1))); } from_t mhs_mpz_get_d(int s) { return mhs_from_Double(s, 1, mpz_get_d(mhs_to_Ptr(s, 0))); } from_t mhs_mpz_get_f(int s) { return mhs_from_Float(s, 1, (float)mpz_get_d(mhs_to_Ptr(s, 0))); } from_t mhs_mpz_get_si(int s) { return mhs_from_Int(s, 1, mpz_get_si_(mhs_to_Ptr(s, 0))); } from_t mhs_mpz_init_set_si(int s) { mpz_init_set_si(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_mpz_init_set_ui(int s) { mpz_init_set_ui(mhs_to_Ptr(s, 0), mhs_to_Word(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_mpz_ior(int s) { mpz_ior(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_mul(int s) { mpz_mul(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_mul_2exp(int s) { mpz_mul_2exp(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Int(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_neg(int s) { mpz_neg(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_mpz_popcount(int s) { mpz_ptr a = mhs_to_Ptr(s, 0); from_t r; if (mpz_sgn(a) < 0) { mpz_t neg_a; mpz_init(neg_a); mpz_neg(neg_a, a); r = mhs_from_Int(s, 1, -mpz_popcount(neg_a)); mpz_clear(neg_a); } else { r = mhs_from_Int(s, 1, mpz_popcount(a)); } return r; } from_t mhs_mpz_sub(int s) { mpz_sub(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_fdiv_q_2exp(int s) { mpz_fdiv_q_2exp(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Int(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_tdiv_qr(int s) { mpz_tdiv_qr(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2), mhs_to_Ptr(s, 3)); return mhs_from_Unit(s, 4); } from_t mhs_mpz_tstbit(int s) { return mhs_from_Int(s, 2, mpz_tstbit(mhs_to_Ptr(s, 0), mhs_to_Int(s, 1))); } from_t mhs_mpz_xor(int s) { mpz_xor(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1), mhs_to_Ptr(s, 2)); return mhs_from_Unit(s, 3); } from_t mhs_mpz_init_set_si64(int s) { mpz_init_set_si64(mhs_to_Ptr(s, 0), mhs_to_Int64(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_mpz_init_set_ui64(int s) { mpz_init_set_ui64(mhs_to_Ptr(s, 0), mhs_to_Word64(s, 1)); return mhs_from_Unit(s, 2); } from_t mhs_mpz_get_si64(int s) { return mhs_from_Int64(s, 1, mpz_get_si64(mhs_to_Ptr(s, 0))); } from_t mhs_mpz_log2(int s) { mpz_ptr a = mhs_to_Ptr(s, 0); return mhs_from_Int(s, 1, mpz_sizeinbase(a, 2) - 1); } #endif /* WANT_GMP */ #if WANT_TIME from_t mhs_gettimeofday(int s) { return mhs_from_Int(s, 2, gettimeofday(mhs_to_Ptr(s, 0), mhs_to_Ptr(s, 1))); } #endif #if WANT_ERRNO from_t mhs_E2BIG(int s) { return mhs_from_Int(s, 0, E2BIG); } from_t mhs_EAGAIN(int s) { return mhs_from_Int(s, 0, EAGAIN); } from_t mhs_EINTR(int s) { return mhs_from_Int(s, 0, EINTR); } from_t mhs_EINVAL(int s) { return mhs_from_Int(s, 0, EINVAL); } from_t mhs_EWOULDBLOCK(int s) { return mhs_from_Int(s, 0, EWOULDBLOCK); } from_t mhs_addr_errno(int s) { return mhs_from_Ptr(s, 0, &errno); } from_t mhs_strerror_r(int s) { return mhs_from_Int(s, 3, strerror_r(mhs_to_Int(s, 0), mhs_to_Ptr(s, 1), mhs_to_Word(s, 2))); } #endif const struct ffi_entry ffi_table[] = { { "GETRAW", 0, mhs_GETRAW}, { "GETTIMEMILLI", 0, mhs_GETTIMEMILLI}, #if WANT_MATH #if WANT_FLOAT64 { "acos", 1, mhs_acos}, { "asin", 1, mhs_asin}, { "atan", 1, mhs_atan}, { "atan2", 2, mhs_atan2}, { "cos", 1, mhs_cos}, { "exp", 1, mhs_exp}, { "log", 1, mhs_log}, { "sin", 1, mhs_sin}, { "sqrt", 1, mhs_sqrt}, { "tan", 1, mhs_tan}, { "scalbn", 2, mhs_scalbn}, { "poke_flt64", 2, mhs_poke_flt64 }, { "peek_flt64", 1, mhs_peek_flt64 }, #endif /* WANT_FLOAT64 */ #if WANT_FLOAT32 { "acosf", 1, mhs_acosf}, { "asinf", 1, mhs_asinf}, { "atanf", 1, mhs_atanf}, { "atan2f", 2, mhs_atan2f}, { "cosf", 1, mhs_cosf}, { "expf", 1, mhs_expf}, { "logf", 1, mhs_logf}, { "sinf", 1, mhs_sinf}, { "sqrtf", 1, mhs_sqrtf}, { "tanf", 1, mhs_tanf}, { "scalbnf", 2, mhs_scalbnf}, { "poke_flt32", 2, mhs_poke_flt32 }, { "peek_flt32", 1, mhs_peek_flt32 }, #endif /* WANT_FLOAT32 */ #endif /* WANT_MATH */ #if defined(__EMSCRIPTEN__) { "js_debug", 1, mhs_js_debug}, { "js_eval_run", 1, mhs_js_eval_run}, { "js_eval_call", 1, mhs_js_eval_call}, { "js_set_haskellCallback", 1, mhs_js_set_haskellCallback}, #endif #if WANT_STDIO { "add_FILE", 1, mhs_add_FILE}, { "putchar", 1, mhs_putchar}, { "fopen", 2, mhs_fopen}, { "tmpname", 2, mhs_tmpname}, { "unlink", 1, mhs_unlink}, { "system", 1, mhs_system}, #endif /* WANT_STDIO */ #if WANT_FD { "add_fd", 1, mhs_add_fd}, { "open", 3, mhs_open}, #endif /* WANT_FD */ #if WANT_BUF { "add_buf", 2, mhs_add_buf}, #endif /* WANT_BUF */ #if WANT_CRLF { "add_crlf", 1, mhs_add_crlf}, #endif /* WANT_CRLF */ #if WANT_UTF8 { "add_utf8", 1, mhs_add_utf8}, #endif /* WANT_UTF8 */ #if WANT_BASE64 { "add_base64_encoder", 1, mhs_add_base64_encoder}, { "add_base64_decoder", 1, mhs_add_base64_decoder}, #endif /* WANT_BASE64 */ { "closeb", 1, mhs_closeb}, { "&closeb", 0, mhs_addr_closeb}, { "flushb", 1, mhs_flushb}, { "getb", 1, mhs_getb}, { "putb", 2, mhs_putb}, { "ungetb", 2, mhs_ungetb}, { "openb_wr_mem", 0, mhs_openwrmem}, { "openb_rd_mem", 2, mhs_openrdmem}, { "get_mem", 3, mhs_getmem}, { "readb", 3, mhs_readb}, { "writeb", 3, mhs_writeb}, #if WANT_MD5 { "md5Array", 3, mhs_md5Array}, { "md5BFILE", 2, mhs_md5BFILE}, { "md5String", 2, mhs_md5String}, #endif /* WANT_MD5 */ #if WANT_LZ77 { "add_lz77_compressor", 1, mhs_add_lz77_compressor}, { "add_lz77_decompressor", 1, mhs_add_lz77_decompressor}, { "lz77c", 3, mhs_lz77c}, #endif /* WANT_LZ77 */ #if WANT_RLE { "add_rle_compressor", 1, mhs_add_rle_compressor}, { "add_rle_decompressor", 1, mhs_add_rle_decompressor}, #endif /* WANT_RLE */ #if WANT_BWT { "add_bwt_compressor", 1, mhs_add_bwt_compressor}, { "add_bwt_decompressor", 1, mhs_add_bwt_decompressor}, #endif /* WANT_RLE */ { "calloc", 2, mhs_calloc}, { "realloc", 2, mhs_realloc}, { "free", 1, mhs_free}, { "&free", 0, mhs_addr_free}, { "getenv", 1, mhs_getenv}, { "environ", 0, mhs_environ}, { "iswindows", 0, mhs_iswindows}, { "ismacos", 0, mhs_ismacos}, { "islinux", 0, mhs_islinux}, { "malloc", 1, mhs_malloc}, { "memcpy", 3, mhs_memcpy}, { "memmove", 3, mhs_memmove}, { "strlen", 1, mhs_strlen}, { "strcpy", 2, mhs_strcpy}, { "peekPtr", 1, mhs_peekPtr}, { "peekWord", 1, mhs_peekWord}, { "pokePtr", 2, mhs_pokePtr}, { "pokeWord", 2, mhs_pokeWord}, { "peek_uint8", 1, mhs_peek_uint8}, { "poke_uint8", 2, mhs_poke_uint8}, { "peek_uint16", 1, mhs_peek_uint16}, { "poke_uint16", 2, mhs_poke_uint16}, #if WORD_SIZE >= 32 { "peek_uint32", 1, mhs_peek_uint32}, { "poke_uint32", 2, mhs_poke_uint32}, #endif /* WORD_SIZE >= 32 */ #if WORD_SIZE >= 64 { "peek_uint64", 1, mhs_peek_uint64}, { "poke_uint64", 2, mhs_poke_uint64}, #endif /* WORD_SIZE >= 64 */ { "peek_uint", 1, mhs_peek_uint}, { "poke_uint", 2, mhs_poke_uint}, { "peek_int8", 1, mhs_peek_int8}, { "poke_int8", 2, mhs_poke_int8}, { "peek_int16", 1, mhs_peek_int16}, { "poke_int16", 2, mhs_poke_int16}, #if WORD_SIZE >= 32 { "peek_int32", 1, mhs_peek_int32}, { "poke_int32", 2, mhs_poke_int32}, #endif /* WORD_SIZE >= 32 */ #if WORD_SIZE >= 64 { "peek_int64", 1, mhs_peek_int64}, { "poke_int64", 2, mhs_poke_int64}, #endif /* WORD_SIZE >= 64 */ { "peek_int", 1, mhs_peek_int}, { "poke_int", 2, mhs_poke_int}, { "peek_llong", 1, mhs_peek_llong}, { "peek_long", 1, mhs_peek_long}, { "peek_ullong", 1, mhs_peek_ullong}, { "peek_ulong", 1, mhs_peek_ulong}, { "peek_size_t", 1, mhs_peek_size_t}, { "poke_llong", 2, mhs_poke_llong}, { "poke_long", 2, mhs_poke_long}, { "poke_ullong", 2, mhs_poke_ullong}, { "poke_ulong", 2, mhs_poke_ulong}, { "poke_size_t", 2, mhs_poke_size_t}, #if WANT_FLOAT { "peek_flt", 1, mhs_peek_flt}, { "poke_flt", 2, mhs_poke_flt}, #endif /* WANT_FLOAT */ { "sizeof_char", 0, mhs_sizeof_char}, { "sizeof_short", 0, mhs_sizeof_short}, { "sizeof_int", 0, mhs_sizeof_int}, { "sizeof_llong", 0, mhs_sizeof_llong}, { "sizeof_long", 0, mhs_sizeof_long}, { "sizeof_size_t", 0, mhs_sizeof_size_t}, #if WANT_DIR { "c_d_name", 1, mhs_c_d_name}, { "closedir", 1, mhs_closedir}, { "opendir", 1, mhs_opendir}, { "readdir", 1, mhs_readdir}, { "chdir", 1, mhs_chdir}, { "mkdir", 2, mhs_mkdir}, { "getcwd", 2, mhs_getcwd}, #endif /* WANT_DIR */ { "getcpu", 2, mhs_getcpu}, { "want_gmp", 0, mhs_want_gmp}, #if WANT_GMP { "new_mpz", 0, mhs_new_mpz}, { "mpz_abs", 2, mhs_mpz_abs}, { "mpz_add", 3, mhs_mpz_add}, { "mpz_and", 3, mhs_mpz_and}, { "mpz_cmp", 2, mhs_mpz_cmp}, { "mpz_get_d", 1, mhs_mpz_get_d}, { "mpz_get_si", 1, mhs_mpz_get_si}, { "mpz_init_set_si", 2, mhs_mpz_init_set_si}, { "mpz_init_set_ui", 2, mhs_mpz_init_set_ui}, { "mpz_ior", 3, mhs_mpz_ior}, { "mpz_mul", 3, mhs_mpz_mul}, { "mpz_mul_2exp", 3, mhs_mpz_mul_2exp}, { "mpz_neg", 2, mhs_mpz_neg}, { "mpz_popcount", 1, mhs_mpz_popcount}, { "mpz_sub", 3, mhs_mpz_sub}, { "mpz_fdiv_q_2exp", 3, mhs_mpz_fdiv_q_2exp}, { "mpz_tdiv_qr", 4, mhs_mpz_tdiv_qr}, { "mpz_tstbit", 2, mhs_mpz_tstbit}, { "mpz_xor", 3, mhs_mpz_xor}, { "mpz_get_f", 1, mhs_mpz_get_f}, { "mpz_init_set_si64", 2, mhs_mpz_init_set_si64}, { "mpz_init_set_ui64", 2, mhs_mpz_init_set_ui64}, { "mpz_get_si64", 1, mhs_mpz_get_si64}, { "mpz_log2", 1, mhs_mpz_log2}, #endif /* WANT_GMP */ #if WANT_TIME { "gettimeofday", 2, mhs_gettimeofday}, #endif #if WANT_ERRNO { "E2BIG", 0, mhs_E2BIG}, { "EAGAIN", 0, mhs_EAGAIN}, { "EINTR", 0, mhs_EINTR}, { "EINVAL", 0, mhs_EINVAL}, { "EWOULDBLOCK", 0, mhs_EWOULDBLOCK}, { "&errno", 0, mhs_addr_errno}, { "strerror_r", 3, mhs_strerror_r}, #endif { 0,0 } }; int num_ffi = sizeof(ffi_table) / sizeof(ffi_table[0]);