int64_t sixty_four_bits(Lisp_Object a) { switch ((int)a & TAG_BITS) { case TAG_FIXNUM: return int_of_fixnum(a); case TAG_NUMBERS: if (is_bignum(a)) { int len = bignum_length(a); switch (len) { case CELL+4: return (int64_t)bignum_digits(a)[0]; /* One word bignum */ case CELL+8: return bignum_digits(a)[0] | ((int64_t)bignum_digits(a)[1] << 31); default: return bignum_digits(a)[0] | ((int64_t)bignum_digits(a)[1] << 31) | ((int64_t)bignum_digits(a)[2] << 62); } } /* else drop through */ case TAG_BOXFLOAT: default: /* * return 0 for all non-fixnums */ return 0; } }
int32_t thirty_two_bits(Lisp_Object a) /* * return a 32 bit integer value for the Lisp integer (fixnum or bignum) * passed down - ignore any higher order bits and return 0 if the arg was * floating, rational etc or not a number at all. Only really wanted where * links between C-specific code (that might really want 32-bit values) * and Lisp are being coded. */ { switch ((int)a & TAG_BITS) { case TAG_FIXNUM: return int_of_fixnum(a); case TAG_NUMBERS: if (is_bignum(a)) { int len = bignum_length(a); /* * Note that I keep 31 bits per word and use a 2s complement representation. * thus if I have a one-word bignum I just want its contents but in all * other cases I need just one bit from the next word up. */ if (len == CELL+4) return bignum_digits(a)[0]; /* One word bignum */ return bignum_digits(a)[0] | (bignum_digits(a)[1] << 31); } /* else drop through */ case TAG_BOXFLOAT: default: /* * return 0 for all non-fixnums */ return 0; } }
void seek_live(term_t *tp, apr_memnode_t *newest, heap_t *hp) { term_t t = *tp; apr_memnode_t *node; term_box_t *ptr; // newest node - the node last generation the term may belong to // the node chain starts with the newest and goes to hp->gc_spot if (is_immed(t)) return; ptr = peel(t); node = newest; while (node != hp->gc_spot) { if (node_contains(node, ptr)) { // the term belongs to the newer generation // of terms; recurse to find possible references // to live terms in hp->gc_spot // only tuples, conses, funs (frozen) // and binaries (data, parent) contain references // order of popularity: // cons - tuple - binary - fun if (is_cons(t)) { seek_live(&ptr->cons.head, node, hp); seek_live(&ptr->cons.tail, node, hp); } else if (is_tuple(t)) { int i; int n = ptr->tuple.size; for (i = 0; i < n; i++) seek_live(&ptr->tuple.elts[i], node, hp); } else if (is_binary(t)) { if (ptr->binary.parent != noval) { term_box_t *parent; seek_live(&ptr->binary.parent, node, hp); parent = peel(ptr->binary.parent); ptr->binary.data = parent->binary.data + ptr->binary.offset; } } else if (is_fun(t)) { seek_live(&ptr->fun.frozen, node, hp); } return; } node = node->next; } if (node_contains(hp->gc_spot, ptr)) { // the term should be recreated // the term may have already been moved // and the term value has been replaced with // the buried reference to the new location if (is_grave(t)) { *tp = ptr->grave.skeleton; return; } // list - tuple - binary - fun - bignum - pid - float if (is_list(t)) { term_t cons = heap_cons2(hp, ptr->cons.head, ptr->cons.tail); term_box_t *box = peel(cons); seek_live(&box->cons.head, hp->gc_spot, hp); seek_live(&box->cons.tail, hp->gc_spot, hp); *tp = cons; } else if (is_tuple(t)) { term_t tuple = heap_tuple(hp, ptr->tuple.size); term_box_t *box = peel(tuple); int i; for (i = 0; i < ptr->tuple.size; i++) { box->tuple.elts[i] = ptr->tuple.elts[i]; seek_live(&box->tuple.elts[i], hp->gc_spot, hp); } *tp = tuple; } else if (is_binary(t)) { term_t parent = ptr->binary.parent; term_t b; if (parent == noval) b = heap_binary(hp, ptr->binary.bit_size, ptr->binary.data); else { apr_byte_t *data; seek_live(&parent, hp->gc_spot, hp); data = peel(parent)->binary.data + ptr->binary.offset; b = heap_binary_shared(hp, ptr->binary.bit_size, data, parent); } *tp = b; } else if (is_fun(t)) { term_t f = heap_fun(hp, ptr->fun.module, ptr->fun.function, ptr->fun.arity, ptr->fun.uniq, ptr->fun.index, ptr->fun.frozen); seek_live(&peel(f)->fun.frozen, hp->gc_spot, hp); *tp = f; } else if (is_bignum(t)) { mp_int ma = bignum_to_mp(t); *tp = heap_bignum(hp, SIGN(&ma), USED(&ma), DIGITS(&ma)); } else if (is_long_id(t)) { *tp = heap_long_id(hp, ptr->long_id.node, ptr->long_id.serial, ptr->long_id.tag_creation); } else // if (is_float(t)) { assert(is_float(t)); *tp = heap_float(hp, float_value(t)); } // bury the term ptr->grave.cross = MAGIC_CROSS; ptr->grave.skeleton = *tp; return; } else { // the term belong to the older generation or // to the literal pool of the module -- ignore return; } }
static CSLbool numeqsr(Lisp_Object a, Lisp_Object b) /* * Here I will rely somewhat on the use of IEEE floating point values * (an in particular the weaker supposition that I have floating point * with a binary radix). Then for equality the denominator of b must * be a power of 2, which I can test for and then account for. */ { Lisp_Object nb = numerator(b), db = denominator(b); double d = float_of_number(a), d1; int x; int32_t dx, w, len; uint32_t u, bit; /* * first I will check that db (which will be positive) is a power of 2, * and set dx to indicate what power of two it is. * Note that db != 0 and that one of the top two words of a bignum * must be nonzero (for normalisation) so I end up with a nonzero * value in the variable 'bit' */ if (is_fixnum(db)) { bit = int_of_fixnum(db); w = bit; if (w != (w & (-w))) return NO; /* not a power of 2 */ dx = 0; } else if (is_numbers(db) && is_bignum(db)) { int32_t lenb = (bignum_length(db)-CELL-4)/4; bit = bignum_digits(db)[lenb]; /* * I need to cope with bignums where the leading digits is zero because * the 0x80000000 bit of the next word down is 1. To do this I treat * the number as having one fewer digits. */ if (bit == 0) bit = bignum_digits(db)[--lenb]; w = bit; if (w != (w & (-w))) return NO; /* not a power of 2 */ dx = 31*lenb; while (--lenb >= 0) /* check that the rest of db is zero */ if (bignum_digits(db)[lenb] != 0) return NO; } else return NO; /* Odd - what type IS db here? Maybe error. */ if ((bit & 0xffffU) == 0) dx += 16, bit = bit >> 16; if ((bit & 0xff) == 0) dx += 8, bit = bit >> 8; if ((bit & 0xf) == 0) dx += 4, bit = bit >> 4; if ((bit & 0x3) == 0) dx += 2, bit = bit >> 2; if ((bit & 0x1) == 0) dx += 1; if (is_fixnum(nb)) { double d1 = (double)int_of_fixnum(nb); /* * The ldexp on the next line could potentially underflow. In that case C * defines that the result 0.0 be returned. To avoid trouble I put in a * special test the relies on that fact that a value represented as a rational * would not have been zero. */ if (dx > 10000) return NO; /* Avoid gross underflow */ d1 = ldexp(d1, (int)-dx); return (d == d1 && d != 0.0); } len = (bignum_length(nb)-CELL-4)/4; if (len == 0) /* One word bignums can be treated specially */ { int32_t v = bignum_digits(nb)[0]; double d1; if (dx > 10000) return NO; /* Avoid gross underflow */ d1 = ldexp((double)v, (int)-dx); return (d == d1 && d != 0.0); } d1 = frexp(d, &x); /* separate exponent from mantissa */ if (d1 == 1.0) d1 = 0.5, x++; /* For Zortech */ dx += x; /* adjust to allow for the denominator */ d1 = ldexp(d1, (int)(dx % 31)); /* can neither underflow nor overflow here */ /* * At most 3 words in the bignum may contain nonzero data - I subtract * the (double) value of those bits off and check that (a) the floating * result left is zero and (b) there are no more bits left. */ dx = dx / 31; if (dx != len) return NO; w = bignum_digits(nb)[len]; d1 = (d1 - (double)w) * TWO_31; u = bignum_digits(nb)[--len]; d1 = (d1 - (double)u) * TWO_31; if (len > 0) { u = bignum_digits(nb)[--len]; d1 = d1 - (double)u; } if (d1 != 0.0) return NO; while (--len >= 0) if (bignum_digits(nb)[len] != 0) return NO; return YES; }
int are_terms_equal(term_t a, term_t b, int exact) { assert(a != b); // should be checked elsewhere if (is_immed(a) || is_immed(b)) { if (exact) return 0; if (is_int(a) && is_boxed(b)) { uint32_t *term_data = peel_boxed(b); return (boxed_tag(term_data) == SUBTAG_FLOAT) && (double)int_value(a) == float_value(term_data); } else if (is_boxed(a) && is_int(b)) { uint32_t *term_data = peel_boxed(a); return (boxed_tag(term_data) == SUBTAG_FLOAT) && (float_value(term_data) == (double)int_value(b)); } return 0; } if (is_cons(a)) { if (is_cons(b)) { do { uint32_t *cons1 = peel_cons(a); uint32_t *cons2 = peel_cons(b); if (cons1[0] != cons2[0] && !are_terms_equal(cons1[0], cons2[0], exact)) return 0; a = cons1[1]; b = cons2[1]; } while (is_cons(a) && is_cons(b)); return (a == b) || are_terms_equal(a, b, exact); } else return 0; } else if (is_tuple(a)) { if (is_tuple(b)) { uint32_t *data1 = peel_tuple(a); uint32_t *data2 = peel_tuple(b); if (data1[0] != data2[0]) return 0; for (int i = 1; i <= data1[0]; i++) if (data1[i] != data2[i] && !are_terms_equal(data1[i], data2[i], exact)) return 0; return 1; } else return 0; } else { assert(is_boxed(a)); if (!is_boxed(b)) return 0; uint32_t *term_data1 = peel_boxed(a); uint32_t *term_data2 = peel_boxed(b); uint32_t subtag = boxed_tag(term_data1); if (!exact && subtag == SUBTAG_FLOAT && is_bignum(term_data2)) return float_value(term_data1) == bignum_to_double((bignum_t *)term_data2); if (!exact && is_bignum(term_data1) && boxed_tag(term_data2) == SUBTAG_FLOAT) return bignum_to_double((bignum_t *)term_data1) == float_value(term_data2); if (subtag != boxed_tag(term_data2) && !(is_binary(term_data1) && is_binary(term_data2))) return 0; switch (subtag) { case SUBTAG_POS_BIGNUM: case SUBTAG_NEG_BIGNUM: { bignum_t *bn1 = (bignum_t *)term_data1; bignum_t *bn2 = (bignum_t *)term_data2; return bignum_compare(bn1, bn2) == 0; } case SUBTAG_FUN: { t_fun_t *f1 = (t_fun_t *)term_data1; t_fun_t *f2 = (t_fun_t *)term_data2; if (f1->module != f2->module || f1->index != f2->index || f1->old_uniq != f2->old_uniq) return 0; int num_free = fun_num_free(term_data1); assert(num_free == fun_num_free(term_data2)); for (int i = 0; i < num_free; i++) { term_t v1 = f1->frozen[i]; term_t v2 = f2->frozen[i]; if (v1 != v2 && !are_terms_equal(v1, v2, exact)) return 0; } return 1; } case SUBTAG_EXPORT: { export_t *e1 = ((t_export_t *)term_data1)->e; export_t *e2 = ((t_export_t *)term_data2)->e; return e1->module == e2->module && e1->function == e2->function && e1->arity == e2->arity; } case SUBTAG_PID: { t_long_pid_t *pid1 = (t_long_pid_t *)term_data1; t_long_pid_t *pid2 = (t_long_pid_t *)term_data2; return pid1->node == pid2->node && pid1->serial == pid2->serial && opr_hdr_id(pid1) == opr_hdr_id(pid2) && opr_hdr_creat(pid1) == opr_hdr_creat(pid2); } case SUBTAG_OID: { t_long_oid_t *oid1 = (t_long_oid_t *)term_data1; t_long_oid_t *oid2 = (t_long_oid_t *)term_data2; return oid1->node == oid2->node && opr_hdr_id(oid1) == opr_hdr_id(oid2) && opr_hdr_creat(oid1) == opr_hdr_creat(oid2); } case SUBTAG_REF: { t_long_ref_t *ref1 = (t_long_ref_t *)term_data1; t_long_ref_t *ref2 = (t_long_ref_t *)term_data2; return ref1->node == ref2->node && ref1->id1 == ref2->id1 && ref1->id2 == ref2->id2 && opr_hdr_id(ref1) == opr_hdr_id(ref2) && opr_hdr_creat(ref1) == opr_hdr_creat(ref2); } case SUBTAG_PROC_BIN: case SUBTAG_HEAP_BIN: case SUBTAG_MATCH_CTX: case SUBTAG_SUB_BIN: { bits_t bs1, bs2; bits_get_real(term_data1, &bs1); bits_get_real(term_data2, &bs2); return (bits_compare(&bs1, &bs2) == 0); } default: assert(subtag == SUBTAG_FLOAT); return float_value(term_data1) == float_value(term_data2); } return 1; } }
int is_term_smaller(term_t a, term_t b) { if (a == b) return 0; if (are_both_immed(a, b)) { if (are_both_int(a, b)) return int_value(a) < int_value(b); if (is_int(a)) // !is_int(b) return 1; if (is_nil(a)) // !is_nil(b) return 0; if (is_nil(b)) // !is_nil(a) return 1; if (is_atom(a)) { if (is_int(b)) return 0; else if (is_atom(b)) { uint8_t *print1 = atoms_get(atom_index(a)); uint8_t *print2 = atoms_get(atom_index(b)); int short_len = (print1[0] < print2[0]) ? print1[0] : print2[0]; int d = memcmp(print1+1, print2+1, short_len); if (d == 0) return print1[0] < print2[0]; return d < 0; } else return 1; } else if (is_short_oid(a)) { if (is_int(b) || is_atom(b)) return 0; else if (is_short_oid(b)) return short_oid_id(a) < short_oid_id(b); else return 1; } else if (is_short_pid(a)) { if (is_int(b) || is_atom(b) || is_short_oid(b)) return 0; else { assert(is_short_pid(b)); return short_pid_id(a) < short_pid_id(b); } } } //TODO: comparison of bignum and float: docs mention the // number 9007199254740992.0 and a loss of transitivity if (!is_immed(a) && !is_immed(b) && primary_tag(a) == primary_tag(b)) { if (is_cons(a)) return is_term_smaller_1(a, b); else if (is_tuple(a)) return is_term_smaller_2(a, b); else { assert(is_boxed(a) && is_boxed(b)); uint32_t *adata = peel_boxed(a); uint32_t *bdata = peel_boxed(b); if (boxed_tag(adata) == boxed_tag(bdata) || (is_binary(adata) && is_binary(bdata)) || (is_bignum(adata) && is_bignum(bdata))) { switch(boxed_tag(adata)) { case SUBTAG_POS_BIGNUM: case SUBTAG_NEG_BIGNUM: return bignum_compare((bignum_t *)adata, (bignum_t *)bdata) < 0; case SUBTAG_FUN: return fun_compare((t_fun_t *)adata, (t_fun_t *)bdata) < 0; case SUBTAG_EXPORT: return export_compare((t_export_t *)adata, (t_export_t *)bdata) < 0; case SUBTAG_PID: return pid_compare((t_long_pid_t *)adata, (t_long_pid_t *)bdata) < 0; case SUBTAG_OID: return oid_compare((t_long_oid_t *)adata, (t_long_oid_t *)bdata) < 0; case SUBTAG_REF: return ref_compare((t_long_ref_t *)adata, (t_long_ref_t *)bdata) < 0; case SUBTAG_PROC_BIN: case SUBTAG_HEAP_BIN: case SUBTAG_MATCH_CTX: case SUBTAG_SUB_BIN: return is_term_smaller_3(adata, bdata); default: assert(boxed_tag(adata) == SUBTAG_FLOAT); return float_value(adata) < float_value(bdata); } } } } // Number comparison with (mandatory) coercion // int use_float = (is_boxed(a) && boxed_tag(peel_boxed(a)) == SUBTAG_FLOAT) || (is_boxed(b) && boxed_tag(peel_boxed(b)) == SUBTAG_FLOAT); if (use_float) { if (is_int(a)) // b is always float return (double)int_value(a) < float_value(peel_boxed(b)); else if (is_boxed(a)) { uint32_t *adata = peel_boxed(a); if (is_bignum(adata)) // b is always float return bignum_to_double((bignum_t *)adata) < float_value(peel_boxed(b)); if (boxed_tag(adata) == SUBTAG_FLOAT) { if (is_int(b)) return float_value(adata) < (double)int_value(b); if (is_boxed(b)) { uint32_t *bdata = peel_boxed(b); if (is_bignum(bdata)) return float_value(adata) < bignum_to_double((bignum_t *)bdata); } } } } else // use integer { if (is_int(a)) { if (is_boxed(b)) { uint32_t *bdata = peel_boxed(b); if (is_bignum(bdata)) { bignum_t *bbn = (bignum_t *)bdata; return !bignum_is_neg(bbn); } assert(boxed_tag(bdata) != SUBTAG_FLOAT); } } else if (is_boxed(a)) { uint32_t *adata = peel_boxed(a); if (is_bignum(adata)) { bignum_t *abn = (bignum_t *)adata; if (is_int(b)) return bignum_is_neg(abn); if (is_boxed(b)) { uint32_t *bdata = peel_boxed(b); if (is_bignum(bdata)) return bignum_compare(abn, (bignum_t *)bdata); assert(boxed_tag(bdata) != SUBTAG_FLOAT); } } assert(boxed_tag(adata) != SUBTAG_FLOAT); } } // a and b are quaranteed to have different types // return term_order(a) < term_order(b); }
//cons - tuple - binary - fun term_t heap_marshal(term_t t, heap_t *hp) { term_box_t *box; if (is_immed(t)) return t; box = peel(t); if (is_cons(t)) { term_t first = nil; term_t last = nil; do { term_box_t *cb = peel(t); term_t v = heap_marshal(cb->cons.head, hp); cons_up(first, last, v, hp); t = cb->cons.tail; } while (is_cons(t)); if (t != nil) peel(last)->cons.tail = heap_marshal(t, hp); return first; } else if (is_tuple(t)) { int n = box->tuple.size; term_t tuple = heap_tuple(hp, n); term_box_t *tb = peel(tuple); int i; for (i = 0; i < n; i++) tb->tuple.elts[i] = heap_marshal(box->tuple.elts[i], hp); return tuple; } else if (is_binary(t)) { //NB: for shared binaries parent not copied; shared becomes root term_t binary = heap_binary(hp, box->binary.bit_size, box->binary.data); return binary; } else if (is_bignum(t)) { bignum_t *bb = (bignum_t *)peel(t); term_t biggie = heap_bignum(hp, bb->sign, bb->used, bb->dp); return biggie; } else if (is_float(t)) { term_t f = heap_float(hp, float_value(t)); return f; } else if (is_fun(t)) { term_t fun = heap_fun(hp, box->fun.module, box->fun.function, box->fun.arity, box->fun.uniq, box->fun.index, heap_marshal(box->fun.frozen, hp)); return fun; } else // long_id { term_t id; assert(is_long_id(t)); id = heap_long_id(hp, box->long_id.node, box->long_id.serial, box->long_id.tag_creation); return id; } }
int code_base_load(code_base_t *self, named_tuples_t *nm_tuples, term_t module, term_t exports, term_t fun_table, term_t attrs, term_t preloaded, term_t misc) { module_t *m; apr_pool_t *pool; apr_pool_create(&pool, 0); m = apr_palloc(pool, sizeof(*m)); m->mod_pool = pool; m->literals = heap_make(pool); m->key.module = module; m->key.is_old = 0; m->code_size = 0; m->code = 0; m->exports = apr_hash_make(pool); m->nfuns = 0; m->funs = 0; m->files = 0; m->source = 0; if (preloaded != nil) { int i; int n = list_length(preloaded); term_t cons = preloaded; int ok = 1; m->code = apr_palloc(pool, n*sizeof(codel_t)); m->code_size = n; i = 0; while (ok && is_cons(cons)) { term_box_t *cbox = peel(cons); if (is_int(cbox->cons.head)) { m->code[i].i = int_value(cbox->cons.head); } else if (is_tuple(cbox->cons.head)) { term_box_t *tbox = peel(cbox->cons.head); if (tbox->tuple.size == 2) { term_t selector = tbox->tuple.elts[0]; term_t value = tbox->tuple.elts[1]; switch (selector) { case AT__: // {'@',Offset} m->code[i].l = m->code + int_value(value); break; case A_T: // {t,Literal} m->code[i].t = heap_marshal(value, m->literals); break; case A_B: m->code[i].bif = builtins[int_value(value)].entry; break; case A_N: // {n,{N,F}} if (is_tuple(value)) { term_box_t *vb = peel(value); if (vb->tuple.size == 2) { term_t name = vb->tuple.elts[0]; term_t field = vb->tuple.elts[1]; int index = named_tuples_set(nm_tuples, name, field); m->code[i].t = tag_int(index); } else ok = 0; } else ok = 0; break; default: ok = 0; } } } else if (is_bignum(cbox->cons.head)) { mp_int mp = bignum_to_mp(cbox->cons.head); m->code[i].i = mp_get_int(&mp); } else ok = 0; i++; cons = cbox->cons.tail; } if (!ok) { apr_pool_destroy(pool); return 1; } } // misc: // source line info: // {file,Files} // {source,[{F,L,S,E}]} if (misc != nil) { term_t cons = misc; while (is_cons(cons)) { term_box_t *cb = peel(cons); term_t t = cb->cons.head; if (is_tuple(t)) { term_box_t *tb = peel(t); if (tb->tuple.size >= 2) { term_t selector = tb->tuple.elts[0]; term_t info = tb->tuple.elts[1]; switch (selector) { case A_FILES: m->files = source_files_names(info, pool); break; case A_SOURCE: m->source = source_line_blocks(info, pool); break; } } } cons = cb->cons.tail; } } if (fun_table != nil) { int i; int nfuns = list_length(fun_table); term_t cons = fun_table; int ok = 1; m->funs = apr_palloc(pool, nfuns*sizeof(fun_slot_t)); m->nfuns = nfuns; for (i = 0; ok && i < nfuns; i++) { term_box_t *cbox = peel(cons); if (is_tuple(cbox->cons.head)) { term_box_t *tbox = peel(cbox->cons.head); if (tbox->tuple.size == 2) { term_t uniq = tbox->tuple.elts[0]; term_t offset = tbox->tuple.elts[1]; if ((is_int(uniq) || is_bignum(uniq)) && is_int(offset)) { fun_slot_t *slot = &m->funs[i]; if (is_int(uniq)) slot->uniq = int_value(uniq); else { mp_int mp = bignum_to_mp(uniq); slot->uniq = (uint)mp_get_int(&mp); } slot->entry = m->code + int_value(offset); } else ok = 0; } else ok = 0; } else ok = 0; cons = cbox->cons.tail; } if (!ok) { apr_pool_destroy(pool); return 1; } } //TODO: attrs ingnored if (exports != nil) { int ok = 1; term_t cons = exports; while (ok && is_cons(cons)) { term_box_t *cbox = peel(cons); // {Function,Arity,Offset} if (is_tuple(cbox->cons.head)) { term_box_t *tbox = peel(cbox->cons.head); if (tbox->tuple.size == 3) { term_t function = tbox->tuple.elts[0]; term_t arity = tbox->tuple.elts[1]; term_t offset = tbox->tuple.elts[2]; if (is_atom(function) && is_int(arity) && is_int(offset)) { export_t *exp = apr_palloc(pool, sizeof(*exp)); exp->key.function = function; exp->key.arity = int_value(arity); exp->entry = m->code + int_value(offset); apr_hash_set(m->exports, &exp->key, sizeof(exp->key), exp); } else ok = 0; } else ok = 0; } else ok = 0; cons = cbox->cons.tail; } if (!ok) { apr_pool_destroy(pool); return 1; } } apr_hash_set(self->modules, &m->key, sizeof(m->key), m); return 0; }