From d8132ad204af5131c4cddcf7be4669adfc167ba7 Mon Sep 17 00:00:00 2001 From: JeffBezanson Date: Fri, 2 Jan 2009 23:00:21 +0000 Subject: [PATCH] adding CPRIM type, smaller representation for primitives bug fixes in opaque type handling --- femtolisp/builtins.c | 67 +++++++++---------- femtolisp/cvalues.c | 152 ++++++++++++++++++++++--------------------- femtolisp/equal.c | 81 +++++++++++------------ femtolisp/flisp.c | 60 +++++++++-------- femtolisp/flisp.h | 12 +++- femtolisp/print.c | 12 +++- femtolisp/string.c | 68 ++++++++++--------- femtolisp/todo | 12 +++- femtolisp/types.c | 5 -- 9 files changed, 246 insertions(+), 223 deletions(-) diff --git a/femtolisp/builtins.c b/femtolisp/builtins.c index 9f67f74..4587f91 100644 --- a/femtolisp/builtins.c +++ b/femtolisp/builtins.c @@ -174,23 +174,21 @@ value_t fl_constantp(value_t *args, u_int32_t nargs) value_t fl_fixnum(value_t *args, u_int32_t nargs) { argcount("fixnum", nargs, 1); - if (isfixnum(args[0])) + if (isfixnum(args[0])) { return args[0]; - if (iscvalue(args[0])) { + } + else if (iscprim(args[0])) { + cprim_t *cp = (cprim_t*)ptr(args[0]); + return fixnum(conv_to_long(cp_data(cp), cp_numtype(cp))); + } + else if (isstring(args[0])) { cvalue_t *cv = (cvalue_t*)ptr(args[0]); - long i; - if (cv_isstr(cv)) { - char *pend; - errno = 0; - i = strtol(cv_data(cv), &pend, 0); - if (*pend != '\0' || errno!=0) - lerror(ArgError, "fixnum: invalid string"); - return fixnum(i); - } - else if (valid_numtype(cv_numtype(cv))) { - i = conv_to_long(cv_data(cv), cv_numtype(cv)); - return fixnum(i); - } + char *pend; + errno = 0; + long i = strtol(cv_data(cv), &pend, 0); + if (*pend != '\0' || errno!=0) + lerror(ArgError, "fixnum: invalid string"); + return fixnum(i); } lerror(ArgError, "fixnum: cannot convert argument"); } @@ -200,22 +198,20 @@ value_t fl_truncate(value_t *args, u_int32_t nargs) argcount("truncate", nargs, 1); if (isfixnum(args[0])) return args[0]; - if (iscvalue(args[0])) { - cvalue_t *cv = (cvalue_t*)ptr(args[0]); - void *data = cv_data(cv); - numerictype_t nt = cv_numtype(cv); - if (valid_numtype(nt)) { - double d; - if (nt == T_FLOAT) - d = (double)*(float*)data; - else if (nt == T_DOUBLE) - d = *(double*)data; - else - return args[0]; - if (d > 0) - return return_from_uint64((uint64_t)d); - return return_from_int64((int64_t)d); - } + if (iscprim(args[0])) { + cprim_t *cp = (cprim_t*)ptr(args[0]); + void *data = cp_data(cp); + numerictype_t nt = cp_numtype(cp); + double d; + if (nt == T_FLOAT) + d = (double)*(float*)data; + else if (nt == T_DOUBLE) + d = *(double*)data; + else + return args[0]; + if (d > 0) + return return_from_uint64((uint64_t)d); + return return_from_int64((int64_t)d); } type_error("truncate", "number", args[0]); } @@ -253,11 +249,10 @@ static double todouble(value_t a, char *fname) { if (isfixnum(a)) return (double)numval(a); - if (iscvalue(a)) { - cvalue_t *cv = (cvalue_t*)ptr(a); - numerictype_t nt = cv_numtype(cv); - if (valid_numtype(nt)) - return conv_to_double(cv_data(cv), nt); + if (iscprim(a)) { + cprim_t *cp = (cprim_t*)ptr(a); + numerictype_t nt = cp_numtype(cp); + return conv_to_double(cp_data(cp), nt); } type_error(fname, "number", a); } diff --git a/femtolisp/cvalues.c b/femtolisp/cvalues.c index 1139060..3133a5a 100644 --- a/femtolisp/cvalues.c +++ b/femtolisp/cvalues.c @@ -117,11 +117,21 @@ void cv_autorelease(cvalue_t *cv) autorelease(cv); } +static value_t cprim(fltype_t *type, size_t sz) +{ + cprim_t *pcp = (cprim_t*)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)) { + return cprim(type, sz); + } if (type->eltype == bytetype) { if (sz == 0) return symbol_value(emptystringsym); @@ -155,11 +165,9 @@ value_t cvalue(fltype_t *type, size_t sz) value_t cvalue_from_data(fltype_t *type, void *data, size_t sz) { - cvalue_t *pcv; value_t cv; cv = cvalue(type, sz); - pcv = (cvalue_t*)ptr(cv); - memcpy(cv_data(pcv), data, sz); + memcpy(cptr(cv), data, sz); return cv; } @@ -242,35 +250,29 @@ static void cvalue_##typenam##_init(fltype_t *type, value_t arg, \ if (isfixnum(arg)) { \ n = numval(arg); \ } \ - else if (iscvalue(arg)) { \ - cvalue_t *cv = (cvalue_t*)ptr(arg); \ - void *p = cv_data(cv); \ - if (valid_numtype(cv_numtype(cv))) \ - n = (ctype##_t)conv_to_##cnvt(p, cv_numtype(cv)); \ - else \ - goto cnvt_error; \ + else if (iscprim(arg)) { \ + cprim_t *cp = (cprim_t*)ptr(arg); \ + void *p = cp_data(cp); \ + n = (ctype##_t)conv_to_##cnvt(p, cp_numtype(cp)); \ } \ else { \ - goto cnvt_error; \ + type_error(#typenam, "number", arg); \ } \ *((ctype##_t*)dest) = n; \ - return; \ - cnvt_error: \ - type_error(#typenam, "number", arg); \ } \ value_t cvalue_##typenam(value_t *args, u_int32_t nargs) \ { \ if (nargs==0) { PUSH(fixnum(0)); args = &Stack[SP-1]; } \ - value_t cv = cvalue(typenam##type, sizeof(ctype##_t)); \ + value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \ cvalue_##typenam##_init(typenam##type, \ - args[0], &((cvalue_t*)ptr(cv))->_space[0]); \ - return cv; \ + args[0], cp_data((cprim_t*)ptr(cp))); \ + return cp; \ } \ value_t mk_##typenam(ctype##_t n) \ { \ - value_t cv = cvalue(typenam##type, sizeof(ctype##_t)); \ - *(ctype##_t*)&((cvalue_t*)ptr(cv))->_space[0] = n; \ - return cv; \ + value_t cp = cprim(typenam##type, sizeof(ctype##_t)); \ + *(ctype##_t*)cp_data((cprim_t*)ptr(cp)) = n; \ + return cp; \ } num_ctor(int8, int8, int32, T_INT8) @@ -305,11 +307,9 @@ size_t toulong(value_t n, char *fname) { if (isfixnum(n)) return numval(n); - if (iscvalue(n)) { - cvalue_t *cv = (cvalue_t*)ptr(n); - if (valid_numtype(cv_numtype(cv))) { - return conv_to_ulong(cv_data(cv), cv_numtype(cv)); - } + if (iscprim(n)) { + cprim_t *cp = (cprim_t*)ptr(n); + return conv_to_ulong(cp_data(cp), cp_numtype(cp)); } type_error(fname, "number", n); return 0; @@ -338,11 +338,12 @@ static void cvalue_enum_init(fltype_t *ft, value_t arg, void *dest) if (isfixnum(arg)) { n = (int)numval(arg); } - else if (iscvalue(arg)) { - cvalue_t *cv = (cvalue_t*)ptr(arg); - if (!valid_numtype(cv_numtype(cv))) - type_error("enum", "number", arg); - n = conv_to_int32(cv_data(cv), cv_numtype(cv)); + else if (iscprim(arg)) { + cprim_t *cp = (cprim_t*)ptr(arg); + n = conv_to_int32(cp_data(cp), cp_numtype(cp)); + } + else { + type_error("enum", "number", arg); } if ((unsigned)n >= llength(syms)) lerror(ArgError, "enum: value out of range"); @@ -354,8 +355,8 @@ value_t cvalue_enum(value_t *args, u_int32_t nargs) argcount("enum", nargs, 2); value_t type = list2(enumsym, args[0]); fltype_t *ft = get_type(type); - value_t cv = cvalue(ft, 4); - cvalue_enum_init(ft, args[1], cv_data((cvalue_t*)ptr(cv))); + value_t cv = cvalue(ft, sizeof(int32_t)); + cvalue_enum_init(ft, args[1], cp_data((cprim_t*)ptr(cv))); return cv; } @@ -594,12 +595,15 @@ size_t ctype_sizeof(value_t type, int *palign) value_t cvalue_sizeof(value_t *args, u_int32_t nargs) { - cvalue_t *cv; argcount("sizeof", nargs, 1); if (iscvalue(args[0])) { - cv = (cvalue_t*)ptr(args[0]); + cvalue_t *cv = (cvalue_t*)ptr(args[0]); return size_wrap(cv_len(cv)); } + else if (iscprim(args[0])) { + cprim_t *cp = (cprim_t*)ptr(args[0]); + return fixnum(cp_class(cp)->size); + } int a; return size_wrap(ctype_sizeof(args[0], &a)); } @@ -720,7 +724,7 @@ value_t cvalue_new(value_t *args, u_int32_t nargs) else { cv = cvalue(ft, ft->size); if (nargs == 2) - cvalue_init(ft, args[1], cv_data((cvalue_t*)ptr(cv))); + cvalue_init(ft, args[1], cptr(cv)); } return cv; } @@ -763,7 +767,7 @@ static value_t cvalue_array_aref(value_t *args) fltype_t *eltype = cv_class((cvalue_t*)ptr(args[0]))->eltype; value_t el = cvalue(eltype, eltype->size); check_addr_args("aref", args[0], args[1], &data, &index); - char *dest = cv_data((cvalue_t*)ptr(el)); + char *dest = cptr(el); size_t sz = eltype->size; if (sz == 1) *dest = data[index]; @@ -792,8 +796,8 @@ value_t fl_builtin(value_t *args, u_int32_t nargs) { argcount("builtin", nargs, 1); symbol_t *name = tosymbol(args[0], "builtin"); - builtin_t f = (builtin_t)name->dlcache; - if (f == NULL) { + builtin_t f; + if (ismanaged(args[0]) || (f=(builtin_t)name->dlcache) == NULL) { lerror(ArgError, "builtin: function not found"); } return tagptr(f, TAG_BUILTIN); @@ -926,11 +930,11 @@ value_t fl_add_any(value_t *args, u_int32_t nargs, fixnum_t carryIn) Saccum += numval(args[i]); continue; } - else if (iscvalue(args[i])) { - cvalue_t *cv = (cvalue_t*)ptr(args[i]); - void *a = cv_data(cv); + else if (iscprim(args[i])) { + cprim_t *cp = (cprim_t*)ptr(args[i]); + void *a = cp_data(cp); int64_t i64; - switch(cv_numtype(cv)) { + switch(cp_numtype(cp)) { case T_INT8: Saccum += *(int8_t*)a; break; case T_UINT8: Saccum += *(uint8_t*)a; break; case T_INT16: Saccum += *(int16_t*)a; break; @@ -987,13 +991,13 @@ value_t fl_neg(value_t n) if (isfixnum(n)) { return fixnum(-numval(n)); } - else if (iscvalue(n)) { - cvalue_t *cv = (cvalue_t*)ptr(n); - void *a = cv_data(cv); + else if (iscprim(n)) { + cprim_t *cp = (cprim_t*)ptr(n); + void *a = cp_data(cp); uint32_t ui32; int32_t i32; int64_t i64; - switch(cv_numtype(cv)) { + switch(cp_numtype(cp)) { 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); @@ -1032,11 +1036,11 @@ value_t fl_mul_any(value_t *args, u_int32_t nargs, int64_t Saccum) Saccum *= numval(args[i]); continue; } - else if (iscvalue(args[i])) { - cvalue_t *cv = (cvalue_t*)ptr(args[i]); - void *a = cv_data(cv); + else if (iscprim(args[i])) { + cprim_t *cp = (cprim_t*)ptr(args[i]); + void *a = cp_data(cp); int64_t i64; - switch(cv_numtype(cv)) { + switch(cp_numtype(cp)) { case T_INT8: Saccum *= *(int8_t*)a; break; case T_UINT8: Saccum *= *(uint8_t*)a; break; case T_INT16: Saccum *= *(int16_t*)a; break; @@ -1088,18 +1092,18 @@ value_t fl_div2(value_t a, value_t b) int_t ai, bi; int ta, tb; void *aptr=NULL, *bptr=NULL; - cvalue_t *cv; + cprim_t *cp; if (isfixnum(a)) { ai = numval(a); aptr = &ai; ta = T_FIXNUM; } - else if (iscvalue(a)) { - cv = (cvalue_t*)ptr(a); - ta = cv_numtype(cv); + else if (iscprim(a)) { + cp = (cprim_t*)ptr(a); + ta = cp_numtype(cp); if (ta <= T_DOUBLE) - aptr = cv_data(cv); + aptr = cp_data(cp); } if (aptr == NULL) type_error("/", "number", a); @@ -1108,11 +1112,11 @@ value_t fl_div2(value_t a, value_t b) bptr = &bi; tb = T_FIXNUM; } - else if (iscvalue(b)) { - cv = (cvalue_t*)ptr(b); - tb = cv_numtype(cv); + else if (iscprim(b)) { + cp = (cprim_t*)ptr(b); + tb = cp_numtype(cp); if (tb <= T_DOUBLE) - bptr = cv_data(cv); + bptr = cp_data(cp); } if (bptr == NULL) type_error("/", "number", b); @@ -1174,12 +1178,12 @@ value_t fl_div2(value_t a, value_t b) static void *int_data_ptr(value_t a, int *pnumtype, char *fname) { - cvalue_t *cv; - if (iscvalue(a)) { - cv = (cvalue_t*)ptr(a); - *pnumtype = cv_numtype(cv); + cprim_t *cp; + if (iscprim(a)) { + cp = (cprim_t*)ptr(a); + *pnumtype = cp_numtype(cp); if (*pnumtype < T_FLOAT) - return cv_data(cv); + return cp_data(cp); } type_error(fname, "integer", a); return NULL; @@ -1187,14 +1191,14 @@ static void *int_data_ptr(value_t a, int *pnumtype, char *fname) value_t fl_bitwise_not(value_t a) { - cvalue_t *cv; + cprim_t *cp; int ta; void *aptr; - if (iscvalue(a)) { - cv = (cvalue_t*)ptr(a); - ta = cv_numtype(cv); - aptr = cv_data(cv); + if (iscprim(a)) { + cp = (cprim_t*)ptr(a); + ta = cp_numtype(cp); + aptr = cp_data(cp); switch (ta) { case T_INT8: return mk_int8(~*(int8_t *)aptr); case T_UINT8: return mk_uint8(~*(uint8_t *)aptr); @@ -1213,13 +1217,13 @@ value_t fl_bitwise_not(value_t a) #define BITSHIFT_OP(name, op) \ value_t fl_##name(value_t a, int n) \ { \ - cvalue_t *cv; \ + cprim_t *cp; \ int ta; \ void *aptr; \ - if (iscvalue(a)) { \ - cv = (cvalue_t*)ptr(a); \ - ta = cv_numtype(cv); \ - aptr = cv_data(cv); \ + if (iscprim(a)) { \ + cp = (cprim_t*)ptr(a); \ + ta = cp_numtype(cp); \ + aptr = cp_data(cp); \ switch (ta) { \ case T_INT8: return mk_int8((*(int8_t *)aptr) op n); \ case T_UINT8: return mk_uint8((*(uint8_t *)aptr) op n); \ diff --git a/femtolisp/equal.c b/femtolisp/equal.c index 1cf2ea0..4c225b0 100644 --- a/femtolisp/equal.c +++ b/femtolisp/equal.c @@ -33,23 +33,18 @@ static void eq_union(htable_t *table, value_t a, value_t b, ptrhash_put(table, (void*)b, (void*)ca); } -// a is a fixnum, b is a cvalue -static value_t compare_num_cvalue(value_t a, value_t b, int eq) +// a is a fixnum, b is a cprim +static value_t compare_num_cprim(value_t a, value_t b, int eq) { - cvalue_t *bcv = (cvalue_t*)ptr(b); - numerictype_t bt; - if (valid_numtype(bt=cv_numtype(bcv))) { - fixnum_t ia = numval(a); - void *bptr = cv_data(bcv); - if (cmp_eq(&ia, T_FIXNUM, bptr, bt)) - return fixnum(0); - if (eq) return fixnum(1); - if (cmp_lt(&ia, T_FIXNUM, bptr, bt)) - return fixnum(-1); - } - else { + cprim_t *bcp = (cprim_t*)ptr(b); + numerictype_t bt = cp_numtype(bcp); + fixnum_t ia = numval(a); + void *bptr = cp_data(bcp); + if (cmp_eq(&ia, T_FIXNUM, bptr, bt)) + return fixnum(0); + if (eq) return fixnum(1); + if (cmp_lt(&ia, T_FIXNUM, bptr, bt)) return fixnum(-1); - } return fixnum(1); } @@ -74,7 +69,7 @@ static value_t bounded_vector_compare(value_t a, value_t b, int bound, int eq) } // strange comparisons are resolved arbitrarily but consistently. -// ordering: number < builtin < cvalue < vector < symbol < cons +// ordering: number < cprim < builtin < cvalue < vector < symbol < cons static value_t bounded_compare(value_t a, value_t b, int bound, int eq) { value_t d; @@ -91,8 +86,8 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq) if (isfixnum(b)) { return (numval(a) < numval(b)) ? fixnum(-1) : fixnum(1); } - if (iscvalue(b)) { - return compare_num_cvalue(a, b, eq); + if (iscprim(b)) { + return compare_num_cprim(a, b, eq); } return fixnum(-1); case TAG_SYM: @@ -104,27 +99,26 @@ static value_t bounded_compare(value_t a, value_t b, int bound, int eq) if (isvector(b)) return bounded_vector_compare(a, b, bound, eq); break; - case TAG_CVALUE: - if (iscvalue(b)) { - cvalue_t *acv=(cvalue_t*)ptr(a), *bcv=(cvalue_t*)ptr(b); - numerictype_t at, bt; - if (valid_numtype(at=cv_numtype(acv)) && - valid_numtype(bt=cv_numtype(bcv))) { - void *aptr = cv_data(acv); - void *bptr = cv_data(bcv); - if (cmp_eq(aptr, at, bptr, bt)) - return fixnum(0); - if (eq) return fixnum(1); - if (cmp_lt(aptr, at, bptr, bt)) - return fixnum(-1); - return fixnum(1); - } - return cvalue_compare(a, b); + case TAG_CPRIM: + if (iscprim(b)) { + cprim_t *acp=(cprim_t*)ptr(a), *bcp=(cprim_t*)ptr(b); + numerictype_t at=cp_numtype(acp), bt=cp_numtype(bcp); + void *aptr=cp_data(acp), *bptr=cp_data(bcp); + if (cmp_eq(aptr, at, bptr, bt)) + return fixnum(0); + if (eq) return fixnum(1); + if (cmp_lt(aptr, at, bptr, bt)) + return fixnum(-1); + return fixnum(1); } else if (isfixnum(b)) { - return fixnum(-numval(compare_num_cvalue(b, a, eq))); + return fixnum(-numval(compare_num_cprim(b, a, eq))); } break; + case TAG_CVALUE: + if (iscvalue(b)) + return cvalue_compare(a, b); + break; case TAG_BUILTIN: if (tagb == TAG_BUILTIN) { return (uintval(a) < uintval(b)) ? fixnum(-1) : fixnum(1); @@ -288,6 +282,7 @@ static uptrint_t bounded_hash(value_t a, int bound) numerictype_t nt; size_t i, len; cvalue_t *cv; + cprim_t *cp; void *data; if (bound <= 0) return 0; uptrint_t h = 0; @@ -301,17 +296,17 @@ static uptrint_t bounded_hash(value_t a, int bound) return inthash(a); case TAG_SYM: return ((symbol_t*)ptr(a))->hash; + case TAG_CPRIM: + cp = (cprim_t*)ptr(a); + data = cp_data(cp); + nt = cp_numtype(cp); + d = conv_to_double(data, nt); + if (d==0) d = 0.0; // normalize -0 + return doublehash(*(int64_t*)&d); case TAG_CVALUE: cv = (cvalue_t*)ptr(a); data = cv_data(cv); - if (valid_numtype(nt=cv_numtype(cv))) { - d = conv_to_double(data, nt); - if (d==0) d = 0.0; // normalize -0 - return doublehash(*(int64_t*)&d); - } - else { - return memhash(data, cv_len(cv)); - } + return memhash(data, cv_len(cv)); case TAG_VECTOR: len = vector_size(a); for(i=0; i < len; i++) { diff --git a/femtolisp/flisp.c b/femtolisp/flisp.c index b5da9b1..8a78e0f 100644 --- a/femtolisp/flisp.c +++ b/femtolisp/flisp.c @@ -197,7 +197,7 @@ static symbol_t *mk_symbol(char *str) sym->binding = UNBOUND; sym->syntax = 0; } - sym->type = NULL; + sym->type = sym->dlcache = NULL; sym->hash = memhash32(str, len)^0xAAAAAAAA; strcpy(&sym->name[0], str); return sym; @@ -351,8 +351,9 @@ static int symchar(char c); static value_t relocate(value_t v) { value_t a, d, nc, first, *pcdr; + uptrint_t t = tag(v); - if (iscons(v)) { + if (t == TAG_CONS) { // iterative implementation allows arbitrarily long cons chains pcdr = &first; do { @@ -370,11 +371,12 @@ static value_t relocate(value_t v) *pcdr = (d==NIL) ? NIL : relocate(d); return first; } - uptrint_t t = tag(v); - if ((t&(t-1)) == 0) return v; // tags 0,1,2,4 - if (isforwarded(v)) - return forwardloc(v); - if (isvector(v)) { + + if ((t&3) == 0) return v; + if (!ismanaged(v)) return v; + if (isforwarded(v)) return forwardloc(v); + + if (t == TAG_VECTOR) { // N.B.: 0-length vectors secretly have space for a first element size_t i, newsz, sz = vector_size(v); newsz = sz; @@ -393,11 +395,20 @@ static value_t relocate(value_t v) vector_elt(nc,i) = NIL; return nc; } - else if (iscvalue(v)) { + else if (t == TAG_CPRIM) { + cprim_t *pcp = (cprim_t*)ptr(v); + size_t nw = CPRIM_NWORDS-1+NWORDS(cp_class(pcp)->size); + cprim_t *ncp = (cprim_t*)alloc_words(nw); + while (nw--) + ((value_t*)ncp)[nw] = ((value_t*)pcp)[nw]; + nc = tagptr(ncp, TAG_CPRIM); + forward(v, nc); + return nc; + } + else if (t == TAG_CVALUE) { return cvalue_relocate(v); } - else if (ismanaged(v)) { - assert(issymbol(v)); + else if (t == TAG_SYM) { gensym_t *gs = (gensym_t*)ptr(v); gensym_t *ng = (gensym_t*)alloc_words(sizeof(gensym_t)/sizeof(void*)); ng->id = gs->id; @@ -571,9 +582,7 @@ static value_t vector_grow(value_t v) int isnumber(value_t v) { - return (isfixnum(v) || - (iscvalue(v) && - valid_numtype(cv_numtype((cvalue_t*)ptr(v))))); + return (isfixnum(v) || iscprim(v)); } // read ----------------------------------------------------------------------- @@ -928,19 +937,21 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) v = fixnum(vector_size(Stack[SP-1])); break; } - else if (iscvalue(Stack[SP-1])) { + else if (iscprim(Stack[SP-1])) { cv = (cvalue_t*)ptr(Stack[SP-1]); - v = cv_type(cv); - if (iscons(v) && car_(v) == arraysym) { - v = size_wrap(cvalue_arraylen(Stack[SP-1])); - break; - } - else if (v == bytesym) { + if (cp_class(cv) == bytetype) { v = fixnum(1); break; } - else if (v == wcharsym) { - v = fixnum(u8_charlen(*(uint32_t*)cv_data(cv))); + else if (cp_class(cv) == wchartype) { + v = fixnum(u8_charlen(*(uint32_t*)cp_data((cprim_t*)cv))); + break; + } + } + else if (iscvalue(Stack[SP-1])) { + cv = (cvalue_t*)ptr(Stack[SP-1]); + if (cv_class(cv)->eltype != NULL) { + v = size_wrap(cvalue_arraylen(Stack[SP-1])); break; } } @@ -999,10 +1010,7 @@ static value_t eval_sexpr(value_t e, uint32_t penv, int tail) break; case F_NUMBERP: argcount("numberp", nargs, 1); - v = ((isfixnum(Stack[SP-1]) || - (iscvalue(Stack[SP-1]) && - valid_numtype(cv_numtype((cvalue_t*)ptr(Stack[SP-1]))) )) - ? T : NIL); + v = (isfixnum(Stack[SP-1]) || iscprim(Stack[SP-1]) ? T : NIL); break; case F_FIXNUMP: argcount("fixnump", nargs, 1); diff --git a/femtolisp/flisp.h b/femtolisp/flisp.h index f5a58dc..4184057 100644 --- a/femtolisp/flisp.h +++ b/femtolisp/flisp.h @@ -30,7 +30,7 @@ typedef struct _symbol_t { } symbol_t; #define TAG_NUM 0x0 - //0x1 unused +#define TAG_CPRIM 0x1 #define TAG_BUILTIN 0x2 #define TAG_VECTOR 0x3 #define TAG_NUM1 0x4 @@ -61,6 +61,7 @@ typedef struct _symbol_t { #define isbuiltinish(x) (tag(x) == TAG_BUILTIN) #define isvector(x) (tag(x) == TAG_VECTOR) #define iscvalue(x) (tag(x) == TAG_CVALUE) +#define iscprim(x) (tag(x) == TAG_CPRIM) #define selfevaluating(x) (tag(x)<6) // comparable with == #define eq_comparable(a,b) (!(((a)|(b))&1)) @@ -212,12 +213,19 @@ typedef struct { #define cv_len(cv) ((cv)->len) #define cv_type(cv) (cv_class(cv)->type) #define cv_data(cv) ((cv)->data) -#define cv_numtype(cv) (cv_class(cv)->numtype) #define cv_isstr(cv) (cv_class(cv)->eltype == bytetype) #define cvalue_data(v) cv_data((cvalue_t*)ptr(v)) #define valid_numtype(v) ((v) < N_NUMTYPES) +#define cp_class(cp) ((cp)->type) +#define cp_type(cp) (cp_class(cp)->type) +#define cp_numtype(cp) (cp_class(cp)->numtype) +#define cp_data(cp) (&(cp)->_space[0]) + +// WARNING: multiple evaluation! +#define cptr(v) \ + (iscprim(v) ? cp_data((cprim_t*)ptr(v)) : cv_data((cvalue_t*)ptr(v))) /* C type names corresponding to cvalues type names */ typedef unsigned long ulong; diff --git a/femtolisp/print.c b/femtolisp/print.c index 75b7d10..896045d 100644 --- a/femtolisp/print.c +++ b/femtolisp/print.c @@ -68,6 +68,9 @@ void print_traverse(value_t v) for(i=0; i < vector_size(v); i++) print_traverse(vector_elt(v,i)); } + else if (iscprim(v)) { + mark_cons(v); + } else { assert(iscvalue(v)); cvalue_t *cv = (cvalue_t*)ptr(v); @@ -342,6 +345,7 @@ void fl_print_child(ios_t *f, value_t v, int princ) } break; case TAG_CVALUE: + case TAG_CPRIM: case TAG_VECTOR: case TAG_CONS: if ((label=(value_t)ptrhash_get(&printconses, (void*)v)) != @@ -377,7 +381,7 @@ void fl_print_child(ios_t *f, value_t v, int princ) outc(']', f); break; } - if (iscvalue(v)) { + if (iscvalue(v) || iscprim(v)) { unmark_cons(v); cvalue_print(f, v, princ); break; @@ -584,7 +588,7 @@ static void cvalue_printdata(ios_t *f, void *data, size_t len, value_t type, void cvalue_print(ios_t *f, value_t v, int princ) { cvalue_t *cv = (cvalue_t*)ptr(v); - void *data = cv_data(cv); + void *data = cptr(v); if (cv_class(cv) == builtintype) { HPOS+=ios_printf(f, "#", @@ -595,7 +599,9 @@ void cvalue_print(ios_t *f, value_t v, int princ) cv_class(cv)->vtable->print(v, f, princ); } else { - cvalue_printdata(f, data, cv_len(cv), cv_type(cv), princ, 0); + value_t type = cv_type(cv); + size_t len = iscprim(v) ? cv_class(cv)->size : cv_len(cv); + cvalue_printdata(f, data, len, type, princ, 0); } } diff --git a/femtolisp/string.c b/femtolisp/string.c index c0cd169..cf9751a 100644 --- a/femtolisp/string.c +++ b/femtolisp/string.c @@ -66,9 +66,8 @@ value_t fl_string_encode(value_t *args, u_int32_t nargs) argcount("string.encode", nargs, 1); if (iscvalue(args[0])) { cvalue_t *cv = (cvalue_t*)ptr(args[0]); - value_t t = cv_type(cv); - if (iscons(t) && car_(t) == arraysym && - iscons(cdr_(t)) && car_(cdr_(t)) == wcharsym) { + fltype_t *t = cv_class(cv); + if (t->eltype == wchartype) { size_t nc = cv_len(cv) / sizeof(uint32_t); uint32_t *ptr = (uint32_t*)cv_data(cv); size_t nbytes = u8_codingsize(ptr, nc); @@ -111,30 +110,32 @@ value_t fl_string(value_t *args, u_int32_t nargs) u_int32_t i; size_t len, sz = 0; cvalue_t *temp; + cprim_t *cp; char *data; uint32_t wc; for(i=0; i < nargs; i++) { - if (issymbol(args[i])) { - sz += strlen(symbol_name(args[i])); + cv = args[i]; + if (issymbol(cv)) { + sz += strlen(symbol_name(cv)); continue; } - else if (iscvalue(args[i])) { - temp = (cvalue_t*)ptr(args[i]); - t = cv_type(temp); + else if (iscprim(cv)) { + cp = (cprim_t*)ptr(cv); + t = cp_type(cp); if (t == bytesym) { sz++; continue; } else if (t == wcharsym) { - wc = *(uint32_t*)cv_data(temp); + wc = *(uint32_t*)cp_data(cp); sz += u8_charlen(wc); continue; } - else if (cv_isstr(temp)) { - sz += cv_len(temp); - continue; - } + } + else if (isstring(cv)) { + sz += cv_len((cvalue_t*)ptr(cv)); + continue; } args[i] = print_to_string(args[i], 0); if (nargs == 1) // convert single value to string @@ -149,21 +150,25 @@ value_t fl_string(value_t *args, u_int32_t nargs) char *name = symbol_name(args[i]); while (*name) *ptr++ = *name++; } - else { - temp = (cvalue_t*)ptr(args[i]); - t = cv_type(temp); - data = cvalue_data(args[i]); + else if (iscprim(args[i])) { + cp = (cprim_t*)ptr(args[i]); + t = cp_type(cp); + data = cp_data(cp); if (t == bytesym) { *ptr++ = *(char*)data; } - else if (t == wcharsym) { + else { + // wchar ptr += u8_wc_toutf8(ptr, *(uint32_t*)data); } - else { - len = cv_len(temp); - memcpy(ptr, data, len); - ptr += len; - } + } + else { + // string + temp = (cvalue_t*)ptr(args[i]); + data = cv_data(temp); + len = cv_len(temp); + memcpy(ptr, data, len); + ptr += len; } } return cv; @@ -266,20 +271,21 @@ value_t fl_string_find(value_t *args, u_int32_t nargs) if (start > len) bounds_error("string.find", args[0], args[2]); char *needle; size_t needlesz; - if (!iscvalue(args[1])) - type_error("string.find", "string", args[1]); - cvalue_t *cv = (cvalue_t*)ptr(args[1]); - if (cv_class(cv) == wchartype) { - uint32_t c = *(uint32_t*)cv_data(cv); + + value_t v = args[1]; + cprim_t *cp = (cprim_t*)ptr(v); + if (iscprim(v) && cp_class(cp) == wchartype) { + uint32_t c = *(uint32_t*)cp_data(cp); if (c <= 0x7f) return mem_find_byte(s, (char)c, start, len); needlesz = u8_toutf8(cbuf, sizeof(cbuf), &c, 1); needle = cbuf; } - else if (cv_class(cv) == bytetype) { - return mem_find_byte(s, *(char*)cv_data(cv), start, len); + else if (iscprim(v) && cp_class(cp) == bytetype) { + return mem_find_byte(s, *(char*)cp_data(cp), start, len); } - else if (isstring(args[1])) { + else if (isstring(v)) { + cvalue_t *cv = (cvalue_t*)ptr(v); needlesz = cv_len(cv); needle = (char*)cv_data(cv); } diff --git a/femtolisp/todo b/femtolisp/todo index 4511e89..1aeb29f 100644 --- a/femtolisp/todo +++ b/femtolisp/todo @@ -12,8 +12,9 @@ * read support for #' for compatibility * #\c read character as code (including UTF-8 support!) * #| |# block comments -- here-data for binary serialization. proposed syntax: +? here-data for binary serialization. proposed syntax: #>size:data, e.g. #>6:000000 +? better read syntax for packed arrays, e.g. #double[3 1 4] * use syntax environment concept for user-defined macros to plug that hole in the semantics * make more builtins generic. if typecheck fails, call out to the @@ -102,9 +103,10 @@ possible optimizations: env in-place in tail position - allocate memory by mmap'ing a large uncommitted block that we cut in half. then each half heap can be grown without moving addresses. -- try making (list ...) a builtin by moving the list-building code to +* try making (list ...) a builtin by moving the list-building code to a static function, see if vararg call performance is affected. - try making foldl a builtin, implement table iterator as table.foldl + . not great, since then it can't be CPS converted * represent lambda environment as a vector (in lispv) x setq builtin (didn't help) (- list builtin, to use cons_reserve) @@ -131,6 +133,10 @@ for internal use: improve by making lambda lists vectors somehow? * fast builtin bounded iteration construct (for lo hi (lambda (x) ...)) * represent guest function as a tagged function pointer; allocate nothing +- when an instance of (array type n) is requested, use (array type) + instead, unless the value is part of an aggregate (e.g. struct). + . this avoids allocating a new type for every size. + . and/or add function array.alloc bugs: * with the fully recursive (simpler) relocate(), the size of cons chains @@ -925,7 +931,7 @@ switch to miser mode, otherwise default is ok, for example: consolidated todo list as of 8/30: * new cvalues, types representation -- use the unused tag for TAG_PRIM, add smaller prim representation +* use the unused tag for TAG_PRIM, add smaller prim representation * finalizers in gc * hashtable * generic aref/aset diff --git a/femtolisp/types.c b/femtolisp/types.c index 0ce19c9..7dcfa34 100644 --- a/femtolisp/types.c +++ b/femtolisp/types.c @@ -66,12 +66,8 @@ fltype_t *get_array_type(value_t eltype) fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, cvinitfunc_t init) { - void **bp = equalhash_bp(&TypeTable, (void*)sym); - if (*bp != HT_NOTFOUND) - return *bp; fltype_t *ft = (fltype_t*)malloc(sizeof(fltype_t)); ft->type = sym; - ((symbol_t*)ptr(sym))->type = ft; ft->size = sz; ft->numtype = N_NUMTYPES; ft->vtable = vtab; @@ -80,7 +76,6 @@ fltype_t *define_opaque_type(value_t sym, size_t sz, cvtable_t *vtab, ft->elsz = 0; ft->marked = 1; ft->init = init; - *bp = ft; return ft; }