ref: f001b95402211734a1a6ac053e73fb4183ee7958
dir: /cvalues.c/
#include "llt.h" #include "flisp.h" #include "operators.h" #include "cvalues.h" #include "types.h" #include "overflows.h" // trigger unconditional GC after this many bytes are allocated #define ALLOC_LIMIT_TRIGGER 67108864 value_t int8sym, uint8sym, int16sym, uint16sym, int32sym, uint32sym; value_t int64sym, uint64sym, bignumsym; value_t longsym, ulongsym, bytesym, runesym; value_t floatsym, doublesym; value_t gftypesym, stringtypesym, runestringtypesym; value_t emptystringsym; value_t structsym, arraysym, enumsym, cfunctionsym, voidsym, pointersym; value_t unionsym; htable_t TypeTable; htable_t reverse_dlsym_lookup_table; fltype_t *mpinttype; static fltype_t *int8type, *uint8type; static fltype_t *int16type, *uint16type; static fltype_t *int32type, *uint32type; static fltype_t *int64type, *uint64type; static fltype_t *longtype, *ulongtype; static fltype_t *floattype, *doubletype; fltype_t *bytetype, *runetype; fltype_t *stringtype, *runestringtype; fltype_t *builtintype; static size_t malloc_pressure = 0; static cvalue_t **Finalizers = nil; static size_t nfinalizers = 0; static size_t maxfinalizers = 0; static void cvalue_init(fltype_t *type, value_t v, void *dest); void add_finalizer(cvalue_t *cv) { if(nfinalizers == maxfinalizers){ size_t nn = maxfinalizers == 0 ? 256 : maxfinalizers*2; cvalue_t **temp = realloc(Finalizers, nn*sizeof(cvalue_t*)); if(temp == nil) lerrorf(MemoryError, "out of memory"); Finalizers = temp; maxfinalizers = nn; } Finalizers[nfinalizers++] = cv; } // remove dead objects from finalization list in-place void sweep_finalizers(void) { cvalue_t **lst = Finalizers; size_t n = 0, ndel = 0, l = nfinalizers; cvalue_t *tmp; #define SWAP_sf(a, b) (tmp = a, a = b, b = tmp, 1) if(l == 0) return; do{ tmp = lst[n]; if(isforwarded((value_t)tmp)){ // object is alive lst[n] = ptr(forwardloc((value_t)tmp)); n++; }else{ fltype_t *t = cv_class(tmp); if(t->vtable != nil && t->vtable->finalize != nil) t->vtable->finalize(tagptr(tmp, TAG_CVALUE)); if(!isinlined(tmp) && owned(tmp)){ memset(cv_data(tmp), 0xbb, cv_len(tmp)); free(cv_data(tmp)); } ndel++; } }while((n < l-ndel) && SWAP_sf(lst[n], lst[n+ndel])); nfinalizers -= ndel; #ifdef VERBOSEGC if(ndel > 0) printf("GC: finalized %d objects\n", ndel); #endif malloc_pressure = 0; } // compute the size of the metadata object for a cvalue static size_t cv_nwords(cvalue_t *cv) { if(isinlined(cv)){ size_t n = cv_len(cv); if(n == 0 || cv_isstr(cv)) n++; return CVALUE_NWORDS - 1 + NWORDS(n); } return CVALUE_NWORDS; } static void autorelease(cvalue_t *cv) { cv->type = (fltype_t*)(((uintptr_t)cv->type) | CV_OWNED_BIT); add_finalizer(cv); } void cv_autorelease(cvalue_t *cv) { autorelease(cv); } static value_t cprim(fltype_t *type, size_t sz) { assert(!ismanaged((uintptr_t)type)); assert(sz == type->size); cprim_t *pcp = alloc_words(CPRIM_NWORDS-1+NWORDS(sz)); pcp->type = type; return tagptr(pcp, TAG_CPRIM); } value_t cvalue(fltype_t *type, size_t sz) { cvalue_t *pcv; int str = 0; if(valid_numtype(type->numtype) && type->numtype != T_MPINT) return cprim(type, sz); if(type->eltype == bytetype){ if(sz == 0) return symbol_value(emptystringsym); sz++; str = 1; } if(sz <= MAX_INL_SIZE){ size_t nw = CVALUE_NWORDS - 1 + NWORDS(sz) + (sz == 0 ? 1 : 0); pcv = alloc_words(nw); pcv->type = type; pcv->data = &pcv->_space[0]; if(type->vtable != nil && type->vtable->finalize != nil) add_finalizer(pcv); }else{ if(malloc_pressure > ALLOC_LIMIT_TRIGGER) gc(0); pcv = alloc_words(CVALUE_NWORDS); pcv->type = type; pcv->data = malloc(sz); autorelease(pcv); malloc_pressure += sz; } if(str) ((char*)pcv->data)[--sz] = '\0'; pcv->len = sz; return tagptr(pcv, TAG_CVALUE); } value_t cvalue_from_data(fltype_t *type, void *data, size_t sz) { value_t cv; cv = cvalue(type, sz); memmove(cptr(cv), data, sz); return cv; } // this effectively dereferences a pointer // just like *p in C, it only removes a level of indirection from the type, // it doesn't copy any data. // this method of creating a cvalue only allocates metadata. // ptr is user-managed; we don't autorelease it unless the // user explicitly calls (autorelease ) on the result of this function. // 'parent' is an optional cvalue that this pointer is known to point // into; NIL if none. value_t cvalue_from_ref(fltype_t *type, void *ptr, size_t sz, value_t parent) { cvalue_t *pcv; value_t cv; pcv = alloc_words(CVALUE_NWORDS); pcv->data = ptr; pcv->len = sz; pcv->type = type; if(parent != NIL){ pcv->type = (fltype_t*)(((uintptr_t)pcv->type) | CV_PARENT_BIT); pcv->parent = parent; } cv = tagptr(pcv, TAG_CVALUE); return cv; } value_t cvalue_string(size_t sz) { return cvalue(stringtype, sz); } value_t cvalue_static_cstring(const char *str) { return cvalue_from_ref(stringtype, (char*)str, strlen(str), NIL); } value_t string_from_cstrn(char *str, size_t n) { value_t v = cvalue_string(n); memmove(cvalue_data(v), str, n); return v; } value_t string_from_cstr(char *str) { return string_from_cstrn(str, strlen(str)); } int fl_isstring(value_t v) { return iscvalue(v) && cv_isstr((cvalue_t*)ptr(v)); } // convert to malloc representation (fixed address) void cv_pin(cvalue_t *cv) { if(!isinlined(cv)) return; size_t sz = cv_len(cv); if(cv_isstr(cv)) sz++; void *data = malloc(sz); memmove(data, cv_data(cv), sz); cv->data = data; autorelease(cv); } #define num_init(ctype, cnvt, tag) \ static int \ cvalue_##ctype##_init(fltype_t *type, value_t arg, void *dest) \ { \ ctype n; \ USED(type); \ if(isfixnum(arg)) \ n = numval(arg); \ else if(iscprim(arg)){ \ cprim_t *cp = (cprim_t*)ptr(arg); \ void *p = cp_data(cp); \ n = (ctype)conv_to_##cnvt(p, cp_numtype(cp)); \ }else \ return 1; \ *((ctype*)dest) = n; \ return 0; \ } num_init(int8_t, int32, T_INT8) num_init(uint8_t, uint32, T_UINT8) num_init(int16_t, int32, T_INT16) num_init(uint16_t, uint32, T_UINT16) num_init(int32_t, int32, T_INT32) num_init(uint32_t, uint32, T_UINT32) num_init(int64_t, int64, T_INT64) num_init(uint64_t, uint64, T_UINT64) num_init(float, double, T_FLOAT) num_init(double, double, T_DOUBLE) #define num_ctor_init(typenam, ctype, tag) \ BUILTIN(#typenam, typenam) \ { \ if(nargs == 0){ \ PUSH(fixnum(0)); \ args = &Stack[SP-1]; \ } \ value_t cp = cprim(typenam##type, sizeof(ctype)); \ if(cvalue_##ctype##_init(typenam##type, args[0], cp_data((cprim_t*)ptr(cp)))) \ type_error("number", args[0]); \ return cp; \ } #define num_ctor_ctor(typenam, ctype, tag) \ value_t mk_##typenam(ctype n) \ { \ value_t cp = cprim(typenam##type, sizeof(ctype)); \ *(ctype*)cp_data((cprim_t*)ptr(cp)) = n; \ return cp; \ } #define num_ctor(typenam, ctype, tag) \ num_ctor_init(typenam, ctype, tag) \ num_ctor_ctor(typenam, ctype, tag) num_ctor(int8, int8_t, T_INT8) num_ctor(uint8, uint8_t, T_UINT8) num_ctor(int16, int16_t, T_INT16) num_ctor(uint16, uint16_t, T_UINT16) num_ctor(int32, int32_t, T_INT32) num_ctor(uint32, uint32_t, T_UINT32) num_ctor(int64, int64_t, T_INT64) num_ctor(uint64, uint64_t, T_UINT64) num_ctor(byte, uint8_t, T_UINT8) #if defined(ULONG64) num_ctor(long, int64_t, T_INT64) num_ctor(ulong, uint64_t, T_UINT64) #else num_ctor(long, int32_t, T_INT32) num_ctor(ulong, uint32_t, T_UINT32) #endif num_ctor(float, float, T_FLOAT) num_ctor(double, double, T_DOUBLE) num_ctor(rune, uint32_t, T_UINT32) static int cvalue_mpint_init(fltype_t *type, value_t arg, void *dest) { mpint *n; USED(type); if(isfixnum(arg)){ n = vtomp(numval(arg), nil); }else if(iscprim(arg)){ cprim_t *cp = (cprim_t*)ptr(arg); void *p = cp_data(cp); n = conv_to_mpint(p, cp_numtype(cp)); }else{ return 1; } *((mpint**)dest) = n; return 0; } BUILTIN("bignum", bignum) { if(nargs == 0){ PUSH(fixnum(0)); args = &Stack[SP-1]; } value_t cv = cvalue(mpinttype, sizeof(mpint*)); if(cvalue_mpint_init(mpinttype, args[0], cv_data((cvalue_t*)ptr(cv)))) type_error("number", args[0]); return cv; } value_t mk_mpint(mpint *n) { value_t cv = cvalue(mpinttype, sizeof(mpint*)); *(mpint**)cvalue_data(cv) = n; return cv; } static void free_mpint(value_t self) { mpint **s = value2c(mpint**, self); if(*s != mpzero && *s != mpone && *s != mptwo) mpfree(*s); } static cvtable_t mpint_vtable = { nil, nil, free_mpint, nil }; value_t size_wrap(size_t sz) { if(fits_fixnum(sz)) return fixnum(sz); assert(sizeof(void*) == sizeof(size_t)); return mk_ulong(sz); } size_t toulong(value_t n) { if(isfixnum(n)) return numval(n); if(iscprim(n)){ cprim_t *cp = (cprim_t*)ptr(n); return conv_to_ulong(cp_data(cp), cp_numtype(cp)); } type_error("number", n); } off_t tooffset(value_t n) { if(isfixnum(n)) return numval(n); if(iscprim(n)){ cprim_t *cp = (cprim_t*)ptr(n); return conv_to_int64(cp_data(cp), cp_numtype(cp)); } type_error("number", n); } int cvalue_enum_init(fltype_t *ft, value_t arg, void *dest) { int n; value_t syms; value_t type = ft->type; syms = car(cdr(type)); if(!isvector(syms)) type_error("vector", syms); if(issymbol(arg)){ for(n = 0; n < (int)vector_size(syms); n++){ if(vector_elt(syms, n) == arg){ *(int*)dest = n; return 0; } } lerrorf(ArgError, "invalid enum value"); } if(isfixnum(arg)) n = (int)numval(arg); else if(iscprim(arg)){ cprim_t *cp = (cprim_t*)ptr(arg); n = conv_to_int32(cp_data(cp), cp_numtype(cp)); }else type_error("number", arg); if((unsigned)n >= vector_size(syms)) lerrorf(ArgError, "value out of range"); *(int*)dest = n; return 0; } BUILTIN("enum", enum) { argcount(nargs, 2); value_t type = fl_list2(enumsym, args[0]); fltype_t *ft = get_type(type); value_t cv = cvalue(ft, sizeof(int32_t)); cvalue_enum_init(ft, args[1], cp_data((cprim_t*)ptr(cv))); return cv; } int isarray(value_t v) { return iscvalue(v) && cv_class((cvalue_t*)ptr(v))->eltype != nil; } static size_t predict_arraylen(value_t arg) { if(isvector(arg)) return vector_size(arg); if(iscons(arg)) return llength(arg); if(arg == NIL) return 0; if(isarray(arg)) return cvalue_arraylen(arg); return 1; } int cvalue_array_init(fltype_t *ft, value_t arg, void *dest) { value_t type = ft->type; size_t elsize, i, cnt, sz; fltype_t *eltype = ft->eltype; elsize = ft->elsz; cnt = predict_arraylen(arg); if(iscons(cdr_(cdr_(type)))){ size_t tc = toulong(car_(cdr_(cdr_(type)))); if(tc != cnt) lerrorf(ArgError, "size mismatch"); } sz = elsize * cnt; if(isvector(arg)){ assert(cnt <= vector_size(arg)); for(i = 0; i < cnt; i++){ cvalue_init(eltype, vector_elt(arg, i), dest); dest = (char*)dest + elsize; } return 0; } if(iscons(arg) || arg == NIL){ i = 0; while(iscons(arg)){ if(i == cnt){ i++; break; } // trigger error cvalue_init(eltype, car_(arg), dest); i++; dest = (char*)dest + elsize; arg = cdr_(arg); } if(i != cnt) lerrorf(ArgError, "size mismatch"); return 0; } if(iscvalue(arg)){ cvalue_t *cv = (cvalue_t*)ptr(arg); if(isarray(arg)){ fltype_t *aet = cv_class(cv)->eltype; if(aet == eltype){ if(cv_len(cv) == sz) memmove(dest, cv_data(cv), sz); else lerrorf(ArgError, "size mismatch"); return 0; }else{ // TODO: initialize array from different type elements lerrorf(ArgError, "element type mismatch"); } } } if(cnt == 1) cvalue_init(eltype, arg, dest); type_error("sequence", arg); } BUILTIN("array", array) { size_t elsize, cnt, sz; value_t arg; int i; if(nargs < 1) argcount(nargs, 1); cnt = nargs - 1; fltype_t *type = get_array_type(args[0]); elsize = type->elsz; sz = elsize * cnt; value_t cv = cvalue(type, sz); char *dest = cv_data(ptr(cv)); FOR_ARGS(i, 1, arg, args){ cvalue_init(type->eltype, arg, dest); dest += elsize; } return cv; } // NOTE: v must be an array size_t cvalue_arraylen(value_t v) { cvalue_t *cv = ptr(v); return cv_len(cv)/cv_class(cv)->elsz; } static size_t cvalue_struct_offs(value_t type, value_t field, int computeTotal, int *palign) { value_t fld = car(cdr_(type)); size_t fsz, ssz = 0; int al; *palign = 0; while(iscons(fld)){ fsz = ctype_sizeof(car(cdr(car_(fld))), &al); ssz = LLT_ALIGN(ssz, al); if(al > *palign) *palign = al; if(!computeTotal && field == car_(car_(fld))) // found target field return ssz; ssz += fsz; fld = cdr_(fld); } return LLT_ALIGN(ssz, *palign); } static size_t cvalue_union_size(value_t type, int *palign) { value_t fld = car(cdr_(type)); size_t fsz, usz = 0; int al; *palign = 0; while(iscons(fld)){ fsz = ctype_sizeof(car(cdr(car_(fld))), &al); if(al > *palign) *palign = al; if(fsz > usz) usz = fsz; fld = cdr_(fld); } return LLT_ALIGN(usz, *palign); } // *palign is an output argument giving the alignment required by type size_t ctype_sizeof(value_t type, int *palign) { symbol_t *s; if(issymbol(type) && (s = ptr(type)) != nil && valid_numtype(s->numtype)){ *palign = s->align; return s->size; } if(iscons(type)){ value_t hed = car_(type); if(hed == structsym) return cvalue_struct_offs(type, NIL, 1, palign); if(hed == unionsym) return cvalue_union_size(type, palign); if(hed == pointersym || hed == cfunctionsym){ *palign = offsetof(struct{ char a; void *i; }, i); return sizeof(void*); } if(hed == arraysym){ value_t t = car(cdr_(type)); if(!iscons(cdr_(cdr_(type)))) lerrorf(ArgError, "incomplete type"); value_t n = car_(cdr_(cdr_(type))); size_t sz = toulong(n); return sz * ctype_sizeof(t, palign); } if(hed == enumsym){ *palign = offsetof(struct{ char c; numerictype_t e; }, e); return sizeof(numerictype_t); } } lerrorf(ArgError, "invalid c type"); } extern fltype_t *iostreamtype; // get pointer and size for any plain-old-data value void to_sized_ptr(value_t v, char **pdata, size_t *psz) { if(iscvalue(v)){ cvalue_t *pcv = ptr(v); ios_t *x = value2c(ios_t*, v); if(cv_class(pcv) == iostreamtype && x->bm == bm_mem){ *pdata = x->buf; *psz = x->size; return; } if(cv_isPOD(pcv)){ *pdata = cv_data(pcv); *psz = cv_len(pcv); return; } } if(iscprim(v)){ cprim_t *pcp = (cprim_t*)ptr(v); *pdata = cp_data(pcp); *psz = cp_class(pcp)->size; return; } type_error("plain-old-data", v); } BUILTIN("sizeof", sizeof) { argcount(nargs, 1); size_t n; char *data; int a; if(issymbol(args[0]) || iscons(args[0])) return size_wrap(ctype_sizeof(args[0], &a)); to_sized_ptr(args[0], &data, &n); return size_wrap(n); } BUILTIN("typeof", typeof) { argcount(nargs, 1); switch(tag(args[0])){ case TAG_CONS: return pairsym; case TAG_NUM1: case TAG_NUM: return fixnumsym; case TAG_SYM: return symbolsym; case TAG_VECTOR: return vectorsym; case TAG_FUNCTION: if(args[0] == FL_T || args[0] == FL_F) return booleansym; if(args[0] == NIL) return nullsym; if(args[0] == FL_EOF) return symbol("eof-object"); if(isbuiltin(args[0])) return builtinsym; return FUNCTION; } return cv_type(ptr(args[0])); } value_t cvalue_relocate(value_t v) { size_t nw; cvalue_t *cv = ptr(v); cvalue_t *nv; value_t ncv; nw = cv_nwords(cv); nv = alloc_words(nw); memmove(nv, cv, nw*sizeof(value_t)); if(isinlined(cv)) nv->data = &nv->_space[0]; ncv = tagptr(nv, TAG_CVALUE); fltype_t *t = cv_class(cv); if(t->vtable != nil && t->vtable->relocate != nil) t->vtable->relocate(v, ncv); forward(v, ncv); return ncv; } value_t cvalue_copy(value_t v) { assert(iscvalue(v)); PUSH(v); cvalue_t *cv = ptr(v); size_t nw = cv_nwords(cv); cvalue_t *ncv = alloc_words(nw); v = POP(); cv = ptr(v); memmove(ncv, cv, nw * sizeof(value_t)); if(!isinlined(cv)){ size_t len = cv_len(cv); if(cv_isstr(cv)) len++; ncv->data = malloc(len); memmove(ncv->data, cv_data(cv), len); autorelease(ncv); if(hasparent(cv)){ ncv->type = (fltype_t*)(((uintptr_t)ncv->type) & ~CV_PARENT_BIT); ncv->parent = NIL; } }else{ ncv->data = &ncv->_space[0]; } return tagptr(ncv, TAG_CVALUE); } BUILTIN("copy", copy) { argcount(nargs, 1); if(iscons(args[0]) || isvector(args[0])) lerrorf(ArgError, "argument must be a leaf atom"); if(!iscvalue(args[0])) return args[0]; if(!cv_isPOD(ptr(args[0]))) lerrorf(ArgError, "argument must be a plain-old-data type"); return cvalue_copy(args[0]); } BUILTIN("plain-old-data?", plain_old_datap) { argcount(nargs, 1); return (iscprim(args[0]) || (iscvalue(args[0]) && cv_isPOD((cvalue_t*)ptr(args[0])))) ? FL_T : FL_F; } static void cvalue_init(fltype_t *type, value_t v, void *dest) { cvinitfunc_t f = type->init; if(f == nil) lerrorf(ArgError, "invalid c type"); f(type, v, dest); } // (new type . args) // this provides (1) a way to allocate values with a shared type for // efficiency, (2) a uniform interface for allocating cvalues of any // type, including user-defined. BUILTIN("c-value", c_value) { if(nargs < 1 || nargs > 2) argcount(nargs, 2); value_t type = args[0]; fltype_t *ft = get_type(type); value_t cv; if(ft->eltype != nil){ // special case to handle incomplete array types bla[] size_t elsz = ft->elsz; size_t cnt; if(iscons(cdr_(cdr_(type)))) cnt = toulong(car_(cdr_(cdr_(type)))); else if(nargs == 2) cnt = predict_arraylen(args[1]); else cnt = 0; cv = cvalue(ft, elsz * cnt); if(nargs == 2) cvalue_array_init(ft, args[1], cv_data(ptr(cv))); }else{ cv = cvalue(ft, ft->size); if(nargs == 2) cvalue_init(ft, args[1], cptr(cv)); } return cv; } // NOTE: this only compares lexicographically; it ignores numeric formats value_t cvalue_compare(value_t a, value_t b) { cvalue_t *ca = ptr(a); cvalue_t *cb = ptr(b); char *adata = cv_data(ca); char *bdata = cv_data(cb); size_t asz = cv_len(ca); size_t bsz = cv_len(cb); size_t minsz = asz < bsz ? asz : bsz; int diff = memcmp(adata, bdata, minsz); if(diff == 0){ if(asz > bsz) return fixnum(1); if(asz < bsz) return fixnum(-1); } return fixnum(diff); } static void check_addr_args(value_t arr, value_t ind, char **data, int *index) { int numel; cvalue_t *cv = ptr(arr); *data = cv_data(cv); numel = cv_len(cv)/cv_class(cv)->elsz; *index = toulong(ind); if(*index >= numel) bounds_error(arr, ind); } value_t cvalue_array_aref(value_t *args) { char *data; int index; fltype_t *eltype = cv_class(ptr(args[0]))->eltype; value_t el = 0; numerictype_t nt = eltype->numtype; if(nt >= T_INT32) el = cvalue(eltype, eltype->size); check_addr_args(args[0], args[1], &data, &index); if(nt < T_INT32){ if(nt == T_INT8) return fixnum((int8_t)data[index]); if(nt == T_UINT8) return fixnum((uint8_t)data[index]); if(nt == T_INT16) return fixnum(((int16_t*)data)[index]); return fixnum(((uint16_t*)data)[index]); } char *dest = cptr(el); size_t sz = eltype->size; if(sz == 1) *dest = data[index]; else if(sz == 2) *(int16_t*)dest = ((int16_t*)data)[index]; else if(sz == 4) *(int32_t*)dest = ((int32_t*)data)[index]; else if(sz == 8) *(int64_t*)dest = ((int64_t*)data)[index]; else memmove(dest, data + index*sz, sz); return el; } value_t cvalue_array_aset(value_t *args) { char *data; int index; fltype_t *eltype = cv_class(ptr(args[0]))->eltype; check_addr_args(args[0], args[1], &data, &index); char *dest = data + index*eltype->size; cvalue_init(eltype, args[2], dest); return args[2]; } BUILTIN("builtin", builtin) { argcount(nargs, 1); symbol_t *name = tosymbol(args[0]); cvalue_t *cv; if(ismanaged(args[0]) || (cv = name->dlcache) == nil) lerrorf(ArgError, "function %s not found", name->name); return tagptr(cv, TAG_CVALUE); } value_t cbuiltin(char *name, builtin_t f) { cvalue_t *cv; cv = calloc(CVALUE_NWORDS, sizeof(*cv)); cv->type = builtintype; cv->data = &cv->_space[0]; cv->len = sizeof(value_t); *(void**)cv->data = f; value_t sym = symbol(name); ((symbol_t*)ptr(sym))->dlcache = cv; ptrhash_put(&reverse_dlsym_lookup_table, cv, (void*)sym); return tagptr(cv, TAG_CVALUE); } #define cv_intern(tok) \ do{ \ tok##sym = symbol(#tok); \ }while(0) #define ctor_cv_intern(tok, nt, ctype) \ do{ \ symbol_t *s; \ cv_intern(tok); \ set(tok##sym, cbuiltin(#tok, fn_builtin_##tok)); \ if(valid_numtype(nt)){ \ s = ptr(tok##sym); \ s->numtype = nt; \ s->size = sizeof(ctype); \ s->align = offsetof(struct{char c; ctype x;}, x); \ } \ }while(0) #define mk_primtype(name, ctype) \ do{ \ name##type = get_type(name##sym); \ name##type->init = cvalue_##ctype##_init; \ }while(0) #define RETURN_NUM_AS(var, type) return(mk_##type(var)) value_t return_from_uint64(uint64_t Uaccum) { if(fits_fixnum(Uaccum)) return fixnum((fixnum_t)Uaccum); if(Uaccum > (uint64_t)INT64_MAX) RETURN_NUM_AS(Uaccum, uint64); if(Uaccum > (uint64_t)UINT32_MAX) RETURN_NUM_AS(Uaccum, int64); if(Uaccum > (uint64_t)INT32_MAX) RETURN_NUM_AS(Uaccum, uint32); RETURN_NUM_AS(Uaccum, int32); } value_t return_from_int64(int64_t Saccum) { if(fits_fixnum(Saccum)) return fixnum((fixnum_t)Saccum); if(Saccum > (int64_t)UINT32_MAX || Saccum < (int64_t)INT32_MIN) RETURN_NUM_AS(Saccum, int64); if(Saccum > (int64_t)INT32_MAX) RETURN_NUM_AS(Saccum, uint32); RETURN_NUM_AS(Saccum, int32); } value_t fl_add_any(value_t *args, uint32_t nargs, fixnum_t carryIn) { uint64_t Uaccum = 0; uint64_t Uresult; int64_t Saccum = carryIn; int64_t Sresult; double Faccum = 0; int32_t inexact = 0; uint32_t i; int64_t i64; value_t arg; mpint *Maccum = nil, *x; numerictype_t pt; fixnum_t pi; void *a; FOR_ARGS(i, 0, arg, args){ if(isfixnum(arg)){ Saccum += numval(arg); continue; } if(num_to_ptr(arg, &pi, &pt, &a)){ switch(pt){ case T_INT8: Saccum += *(int8_t*)a; break; case T_UINT8: Uaccum += *(uint8_t*)a; break; case T_INT16: Saccum += *(int16_t*)a; break; case T_UINT16: Uaccum += *(uint16_t*)a; break; case T_INT32: Saccum += *(int32_t*)a; break; case T_UINT32: Uaccum += *(uint32_t*)a; break; case T_INT64: i64 = *(int64_t*)a; if(i64 > 0){ if(addof_uint64(Uresult, Uaccum, (uint64_t)i64)){ if(Maccum == nil) Maccum = mpnew(0); x = uvtomp((uint64_t)i64, nil); mpadd(Maccum, x, Maccum); mpfree(x); }else Uaccum = Uresult; }else{ if(subof_int64(Sresult, Saccum, i64)){ if(Maccum == nil) Maccum = mpnew(0); x = vtomp(i64, nil); mpadd(Maccum, x, Maccum); mpfree(x); }else{ USED(Sresult); Saccum += i64; } } break; case T_UINT64: if(addof_uint64(Uresult, Uaccum, *(uint64_t*)a)){ if(Maccum == nil) Maccum = mpnew(0); x = uvtomp(*(uint64_t*)a, nil); mpadd(Maccum, x, Maccum); mpfree(x); }else Uaccum = Uresult; break; case T_MPINT: if(Maccum == nil) Maccum = mpnew(0); mpadd(Maccum, *(mpint**)a, Maccum); break; case T_FLOAT: Faccum += *(float*)a; inexact = 1; break; case T_DOUBLE: Faccum += *(double*)a; inexact = 1; break; default: goto add_type_error; } continue; } add_type_error: mpfree(Maccum); type_error("number", arg); } if(inexact){ Faccum += Uaccum; Faccum += Saccum; if(Maccum != nil){ Faccum += mptod(Maccum); mpfree(Maccum); } return mk_double(Faccum); } if(Maccum != nil){ /* FIXME - check if it fits into fixnum first, etc */ x = vtomp(Saccum, nil); mpadd(Maccum, x, Maccum); x = uvtomp(Uaccum, x); mpadd(Maccum, x, Maccum); mpfree(x); return mk_mpint(Maccum); } if(Saccum < 0){ uint64_t negpart = (uint64_t)(-Saccum); if(negpart > Uaccum){ Saccum += (int64_t)Uaccum; // return value in Saccum if(Saccum >= INT32_MIN){ if(fits_fixnum(Saccum)){ return fixnum((fixnum_t)Saccum); } RETURN_NUM_AS(Saccum, int32); } RETURN_NUM_AS(Saccum, int64); } Uaccum -= negpart; }else{ if(addof_uint64(Uresult, Uaccum, (uint64_t)Saccum)){ if(Maccum == nil) Maccum = mpnew(0); x = vtomp(Saccum, nil); mpadd(Maccum, x, Maccum); x = uvtomp(Uaccum, x); mpadd(Maccum, x, Maccum); mpfree(x); return mk_mpint(Maccum); }else Uaccum = Uresult; } return return_from_uint64(Uaccum); } value_t fl_neg(value_t n) { uint32_t ui32; int32_t i32; int64_t i64; mpint *mp; numerictype_t pt; fixnum_t pi; void *a; if(isfixnum(n)){ fixnum_t s = fixnum(-numval(n)); if(__unlikely((value_t)s == n)) return mk_xlong(-numval(n)); return s; } if(num_to_ptr(n, &pi, &pt, &a)){ switch(pt){ case T_INT8: return fixnum(-(int32_t)*(int8_t*)a); case T_UINT8: return fixnum(-(int32_t)*(uint8_t*)a); case T_INT16: return fixnum(-(int32_t)*(int16_t*)a); case T_UINT16: return fixnum(-(int32_t)*(uint16_t*)a); case T_INT32: i32 = *(int32_t*)a; if(i32 == (int32_t)BIT31) return mk_uint32((uint32_t)BIT31); return mk_int32(-i32); case T_UINT32: ui32 = *(uint32_t*)a; if(ui32 <= ((uint32_t)INT32_MAX)+1) return mk_int32(-(int32_t)ui32); return mk_int64(-(int64_t)ui32); case T_INT64: i64 = *(int64_t*)a; if(i64 == (int64_t)BIT63) return mk_uint64((uint64_t)BIT63); return mk_int64(-i64); case T_UINT64: return mk_int64(-(int64_t)*(uint64_t*)a); case T_MPINT: mp = mpcopy(*(mpint**)a); mpsub(mpzero, mp, mp); return mk_mpint(mp); case T_FLOAT: return mk_float(-*(float*)a); case T_DOUBLE: return mk_double(-*(double*)a); } } type_error("number", n); } value_t fl_mul_any(value_t *args, uint32_t nargs, int64_t Saccum) { uint64_t Uaccum = 1; double Faccum = 1; int32_t inexact = 0; int64_t i64; uint32_t i; value_t arg; mpint *Maccum = nil, *x; numerictype_t pt; fixnum_t pi; void *a; FOR_ARGS(i, 0, arg, args){ if(isfixnum(arg)){ Saccum *= numval(arg); continue; } if(num_to_ptr(arg, &pi, &pt, &a)){ switch(pt){ case T_INT8: Saccum *= *(int8_t*)a; break; case T_UINT8: Uaccum *= *(uint8_t*)a; break; case T_INT16: Saccum *= *(int16_t*)a; break; case T_UINT16: Uaccum *= *(uint16_t*)a; break; case T_INT32: Saccum *= *(int32_t*)a; break; case T_UINT32: Uaccum *= *(uint32_t*)a; break; case T_INT64: i64 = *(int64_t*)a; if(i64 > 0) Uaccum *= (uint64_t)i64; else Saccum *= i64; break; case T_UINT64: Uaccum *= *(uint64_t*)a; break; case T_MPINT: if(Maccum == nil) Maccum = mpcopy(mpone); mpmul(Maccum, *(mpint**)a, Maccum); break; case T_FLOAT: Faccum *= *(float*)a; inexact = 1; break; case T_DOUBLE: Faccum *= *(double*)a; inexact = 1; break; default: goto mul_type_error; } continue; } mul_type_error: type_error("number", arg); } if(inexact){ Faccum *= Uaccum; Faccum *= Saccum; if(Maccum != nil){ Faccum *= mptod(Maccum); mpfree(Maccum); } return mk_double(Faccum); } if(Maccum != nil){ /* FIXME might still fit into a fixnum */ x = vtomp(Saccum, nil); mpmul(Maccum, x, Maccum); x = uvtomp(Uaccum, x); mpmul(Maccum, x, Maccum); mpfree(x); return mk_mpint(Maccum); } if(Saccum < 0){ Saccum *= (int64_t)Uaccum; if(Saccum >= INT32_MIN){ if(fits_fixnum(Saccum)){ return fixnum((fixnum_t)Saccum); } RETURN_NUM_AS(Saccum, int32); } RETURN_NUM_AS(Saccum, int64); }else{ Uaccum *= (uint64_t)Saccum; } return return_from_uint64(Uaccum); } int num_to_ptr(value_t a, fixnum_t *pi, numerictype_t *pt, void **pp) { cprim_t *cp; cvalue_t *cv; if(isfixnum(a)){ *pi = numval(a); *pp = pi; *pt = T_FIXNUM; return 1; }else if(iscprim(a)){ cp = ptr(a); *pp = cp_data(cp); *pt = cp_numtype(cp); return 1; }else if(iscvalue(a)){ cv = ptr(a); *pp = cv_data(cv); *pt = cv_class(cv)->numtype; return valid_numtype(*pt); } return 0; } /* returns -1, 0, or 1 based on ordering of a and b eq: consider equality only, returning 0 or nonzero eqnans: NaNs considered equal to each other -0.0 not considered equal to 0.0 inexact not considered equal to exact typeerr: if not 0, throws type errors, else returns 2 for type errors */ int numeric_compare(value_t a, value_t b, int eq, int eqnans, int typeerr) { lltint_t ai, bi; numerictype_t ta, tb; void *aptr, *bptr; if(bothfixnums(a, b)){ if(a == b) return 0; if(numval(a) < numval(b)) return -1; return 1; } if(!num_to_ptr(a, &ai, &ta, &aptr)){ if(typeerr) type_error("number", a); return 2; } if(!num_to_ptr(b, &bi, &tb, &bptr)){ if(typeerr) type_error("number", b); return 2; } if(eq && eqnans && ((ta >= T_FLOAT) != (tb >= T_FLOAT))) return 1; if(cmp_eq(aptr, ta, bptr, tb, eqnans)) return 0; if(eq) return 1; if(cmp_lt(aptr, ta, bptr, tb)) return -1; return 1; } _Noreturn void DivideByZeroError(void) { lerrorf(DivideError, "/: division by zero"); } value_t fl_div2(value_t a, value_t b) { double da, db; lltint_t ai, bi; numerictype_t ta, tb; void *aptr, *bptr; if(!num_to_ptr(a, &ai, &ta, &aptr)) type_error("number", a); if(!num_to_ptr(b, &bi, &tb, &bptr)) type_error("number", b); da = conv_to_double(aptr, ta); db = conv_to_double(bptr, tb); if(db == 0 && tb < T_FLOAT) // exact 0 DivideByZeroError(); da = da/db; if(ta < T_FLOAT && tb < T_FLOAT && (double)(int64_t)da == da) return return_from_int64((int64_t)da); return mk_double(da); } value_t fl_idiv2(value_t a, value_t b) { lltint_t ai, bi; numerictype_t ta, tb; void *aptr, *bptr; int64_t a64, b64; mpint *x; if(!num_to_ptr(a, &ai, &ta, &aptr)) type_error("number", a); if(!num_to_ptr(b, &bi, &tb, &bptr)) type_error("number", b); if(ta == T_MPINT){ if(tb == T_MPINT){ if(mpsignif(*(mpint**)bptr) == 0) goto div_error; x = mpnew(0); mpdiv(*(mpint**)aptr, *(mpint**)bptr, x, nil); return mk_mpint(x); }else{ b64 = conv_to_int64(bptr, tb); if(b64 == 0) goto div_error; x = tb == T_UINT64 ? uvtomp(b64, nil) : vtomp(b64, nil); mpdiv(*(mpint**)aptr, x, x, nil); return mk_mpint(x); } } if(ta == T_UINT64){ if(tb == T_UINT64){ if(*(uint64_t*)bptr == 0) goto div_error; return return_from_uint64(*(uint64_t*)aptr / *(uint64_t*)bptr); } b64 = conv_to_int64(bptr, tb); if(b64 < 0) return return_from_int64(-(int64_t)(*(uint64_t*)aptr / (uint64_t)(-b64))); if(b64 == 0) goto div_error; return return_from_uint64(*(uint64_t*)aptr / (uint64_t)b64); } if(tb == T_UINT64){ if(*(uint64_t*)bptr == 0) goto div_error; a64 = conv_to_int64(aptr, ta); if(a64 < 0) return return_from_int64(-((int64_t)((uint64_t)(-a64) / *(uint64_t*)bptr))); return return_from_uint64((uint64_t)a64 / *(uint64_t*)bptr); } b64 = conv_to_int64(bptr, tb); if(b64 == 0) goto div_error; return return_from_int64(conv_to_int64(aptr, ta) / b64); div_error: DivideByZeroError(); } static value_t fl_bitwise_op(value_t a, value_t b, int opcode) { lltint_t ai, bi; numerictype_t ta, tb, itmp; void *aptr = nil, *bptr = nil, *ptmp; mpint *bmp = nil, *resmp = nil; int64_t b64; if(!num_to_ptr(a, &ai, &ta, &aptr) || ta >= T_FLOAT) type_error("integer", a); if(!num_to_ptr(b, &bi, &tb, &bptr) || tb >= T_FLOAT) type_error("integer", b); if(ta < tb){ itmp = ta; ta = tb; tb = itmp; ptmp = aptr; aptr = bptr; bptr = ptmp; } // now a's type is larger than or same as b's if(ta == T_MPINT){ if(tb == T_MPINT){ bmp = *(mpint**)bptr; resmp = mpnew(0); }else{ bmp = conv_to_mpint(bptr, tb); resmp = bmp; } b64 = 0; }else b64 = conv_to_int64(bptr, tb); switch(opcode){ case 0: switch(ta){ case T_INT8: return fixnum( *(int8_t *)aptr & (int8_t )b64); case T_UINT8: return fixnum( *(uint8_t *)aptr & (uint8_t )b64); case T_INT16: return fixnum( *(int16_t*)aptr & (int16_t )b64); case T_UINT16: return fixnum( *(uint16_t*)aptr & (uint16_t)b64); case T_INT32: return mk_int32( *(int32_t*)aptr & (int32_t )b64); case T_UINT32: return mk_uint32(*(uint32_t*)aptr & (uint32_t)b64); case T_INT64: return mk_int64( *(int64_t*)aptr & (int64_t )b64); case T_UINT64: return mk_uint64(*(uint64_t*)aptr & (uint64_t)b64); case T_MPINT: mpand(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp); case T_FLOAT: case T_DOUBLE: assert(0); } break; case 1: switch(ta){ case T_INT8: return fixnum( *(int8_t *)aptr | (int8_t )b64); case T_UINT8: return fixnum( *(uint8_t *)aptr | (uint8_t )b64); case T_INT16: return fixnum( *(int16_t*)aptr | (int16_t )b64); case T_UINT16: return fixnum( *(uint16_t*)aptr | (uint16_t)b64); case T_INT32: return mk_int32( *(int32_t*)aptr | (int32_t )b64); case T_UINT32: return mk_uint32(*(uint32_t*)aptr | (uint32_t)b64); case T_INT64: return mk_int64( *(int64_t*)aptr | (int64_t )b64); case T_UINT64: return mk_uint64(*(uint64_t*)aptr | (uint64_t)b64); case T_MPINT: mpor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp); case T_FLOAT: case T_DOUBLE: assert(0); } break; case 2: switch(ta){ case T_INT8: return fixnum( *(int8_t *)aptr ^ (int8_t )b64); case T_UINT8: return fixnum( *(uint8_t *)aptr ^ (uint8_t )b64); case T_INT16: return fixnum( *(int16_t*)aptr ^ (int16_t )b64); case T_UINT16: return fixnum( *(uint16_t*)aptr ^ (uint16_t)b64); case T_INT32: return mk_int32( *(int32_t*)aptr ^ (int32_t )b64); case T_UINT32: return mk_uint32(*(uint32_t*)aptr ^ (uint32_t)b64); case T_INT64: return mk_int64( *(int64_t*)aptr ^ (int64_t )b64); case T_UINT64: return mk_uint64(*(uint64_t*)aptr ^ (uint64_t)b64); case T_MPINT: mpxor(*(mpint**)aptr, bmp, resmp); return mk_mpint(resmp); case T_FLOAT: case T_DOUBLE: assert(0); } } assert(0); return NIL; } BUILTIN("logand", logand) { value_t v, e; int i; if(nargs == 0) return fixnum(-1); v = args[0]; FOR_ARGS(i, 1, e, args){ if(bothfixnums(v, e)) v = v & e; else v = fl_bitwise_op(v, e, 0); } return v; } BUILTIN("logior", logior) { value_t v, e; int i; if(nargs == 0) return fixnum(0); v = args[0]; FOR_ARGS(i, 1, e, args){ if(bothfixnums(v, e)) v = v | e; else v = fl_bitwise_op(v, e, 1); } return v; } BUILTIN("logxor", logxor) { value_t v, e; int i; if(nargs == 0) return fixnum(0); v = args[0]; FOR_ARGS(i, 1, e, args){ if(bothfixnums(v, e)) v = fixnum(numval(v) ^ numval(e)); else v = fl_bitwise_op(v, e, 2); } return v; } BUILTIN("lognot", lognot) { argcount(nargs, 1); value_t a = args[0]; cprim_t *cp; int ta; void *aptr; if(isfixnum(a)) return fixnum(~numval(a)); if(iscprim(a)){ cp = ptr(a); ta = cp_numtype(cp); aptr = cp_data(cp); switch(ta){ case T_INT8: return fixnum(~*(int8_t *)aptr); case T_UINT8: return fixnum(~*(uint8_t *)aptr & 0xff); case T_INT16: return fixnum(~*(int16_t *)aptr); case T_UINT16: return fixnum(~*(uint16_t*)aptr & 0xffff); case T_INT32: return mk_int32(~*(int32_t *)aptr); case T_UINT32: return mk_uint32(~*(uint32_t*)aptr); case T_INT64: return mk_int64(~*(int64_t *)aptr); case T_UINT64: return mk_uint64(~*(uint64_t*)aptr); } } type_error("integer", a); } BUILTIN("ash", ash) { fixnum_t n; int64_t accum; cprim_t *cp; int ta; mpint *mp; void *aptr; argcount(nargs, 2); value_t a = args[0]; n = tofixnum(args[1]); if(isfixnum(a)){ if(n <= 0) return fixnum(numval(a)>>(-n)); accum = ((int64_t)numval(a))<<n; return fits_fixnum(accum) ? fixnum(accum) : return_from_int64(accum); } if(iscprim(a) || iscvalue(a)){ if(n == 0) return a; cp = ptr(a); ta = cp_numtype(cp); aptr = cp_data(cp); if(n < 0){ n = -n; switch(ta){ case T_INT8: return fixnum((*(int8_t *)aptr) >> n); case T_UINT8: return fixnum((*(uint8_t *)aptr) >> n); case T_INT16: return fixnum((*(int16_t *)aptr) >> n); case T_UINT16: return fixnum((*(uint16_t*)aptr) >> n); case T_INT32: return mk_int32((*(int32_t *)aptr) >> n); case T_UINT32: return mk_uint32((*(uint32_t*)aptr) >> n); case T_INT64: return mk_int64((*(int64_t *)aptr) >> n); case T_UINT64: return mk_uint64((*(uint64_t*)aptr) >> n); case T_MPINT: aptr = cv_data(cp); mp = mpnew(0); mpright(*(mpint**)aptr, n, mp); return mk_mpint(mp); } } if(ta == T_MPINT){ aptr = cv_data(cp); mp = mpnew(0); mpleft(*(mpint**)aptr, n, mp); return mk_mpint(mp); } if(ta == T_UINT64) return return_from_uint64((*(uint64_t*)aptr)<<n); if(ta < T_FLOAT) return return_from_int64(conv_to_int64(aptr, ta)<<n); } type_error("integer", a); } void cvalues_init(void) { htable_new(&TypeTable, 256); htable_new(&reverse_dlsym_lookup_table, 256); builtintype = define_opaque_type(builtinsym, sizeof(builtin_t), nil, nil); ctor_cv_intern(int8, T_INT8, int8_t); ctor_cv_intern(uint8, T_UINT8, uint8_t); ctor_cv_intern(int16, T_INT16, int16_t); ctor_cv_intern(uint16, T_UINT16, uint16_t); ctor_cv_intern(int32, T_INT32, int32_t); ctor_cv_intern(uint32, T_UINT32, uint32_t); ctor_cv_intern(int64, T_INT64, int64_t); ctor_cv_intern(uint64, T_UINT64, uint64_t); ctor_cv_intern(byte, T_UINT8, uint8_t); #if defined(ULONG64) ctor_cv_intern(long, T_INT64, int64_t); ctor_cv_intern(ulong, T_UINT64, uint64_t); #else ctor_cv_intern(long, T_INT32, int32_t); ctor_cv_intern(ulong, T_UINT32, uint32_t); #endif ctor_cv_intern(rune, T_UINT32, uint32_t); ctor_cv_intern(float, T_FLOAT, float); ctor_cv_intern(double, T_DOUBLE, double); ctor_cv_intern(array, NONNUMERIC, int); ctor_cv_intern(enum, NONNUMERIC, int); cv_intern(pointer); cv_intern(struct); cv_intern(union); cv_intern(void); cfunctionsym = symbol("c-function"); stringtypesym = symbol("*string-type*"); setc(stringtypesym, fl_list2(arraysym, bytesym)); runestringtypesym = symbol("*runestring-type*"); setc(runestringtypesym, fl_list2(arraysym, runesym)); mk_primtype(int8, int8_t); mk_primtype(uint8, uint8_t); mk_primtype(int16, int16_t); mk_primtype(uint16, uint16_t); mk_primtype(int32, int32_t); mk_primtype(uint32, uint32_t); mk_primtype(int64, int64_t); mk_primtype(uint64, uint64_t); #if defined(ULONG64) mk_primtype(long, int64_t); mk_primtype(ulong, uint64_t); #else mk_primtype(long, int32_t); mk_primtype(ulong, uint32_t); #endif mk_primtype(byte, uint8_t); mk_primtype(rune, uint32_t); mk_primtype(float, float); mk_primtype(double, double); ctor_cv_intern(bignum, T_MPINT, mpint*); mpinttype = get_type(bignumsym); mpinttype->init = cvalue_mpint_init; mpinttype->vtable = &mpint_vtable; stringtype = get_type(symbol_value(stringtypesym)); runestringtype = get_type(symbol_value(runestringtypesym)); emptystringsym = symbol("*empty-string*"); setc(emptystringsym, cvalue_static_cstring("")); }