From 94985306911c5e062af854dc9ddea77cf1ec5f9f Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 23 Feb 2018 07:17:23 +0000 Subject: [PATCH] enhanced HCL_BRANDOF() to avoid multiple comparisons. added the eqk? builtin primitive removed unnecessary lines --- lib/comp.c | 4 ++-- lib/gc.c | 2 +- lib/hcl.c | 5 +++++ lib/hcl.h | 31 +++++++++++++++---------------- lib/obj.c | 12 ++++++------ lib/prim.c | 16 ++++++++++++++++ lib/print.c | 53 ++++++++++++++++++++++------------------------------- lib/sym.c | 10 +++++----- 8 files changed, 72 insertions(+), 61 deletions(-) diff --git a/lib/comp.c b/lib/comp.c index de75f8b..46335f0 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -1380,7 +1380,7 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) { hcl_oop_cons_t sdc; - if (HCL_BRANDOF(hcl, cdr) != HCL_BRAND_CONS) + if (!HCL_IS_CONS(hcl, cdr)) { /* (funname . 10) */ hcl_setsynerrbfmt (hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL, "redundant cdr in function call - %O", obj); /* TODO: error location */ @@ -1465,7 +1465,7 @@ static HCL_INLINE int compile_symbol (hcl_t* hcl, hcl_oop_t obj) { hcl_oow_t index; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,obj) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, obj)); if (HCL_OBJ_GET_FLAGS_SYNCODE(obj)) { diff --git a/lib/gc.c b/lib/gc.c index 8861484..24ed7cf 100644 --- a/lib/gc.c +++ b/lib/gc.c @@ -93,7 +93,7 @@ static void compact_symbol_table (hcl_t* hcl, hcl_oop_t _nil) * at the current hash index */ symbol = (hcl_oop_char_t)hcl->symtab->bucket->slot[y]; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,symbol) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, symbol)); z = hcl_hashoochars(symbol->slot, HCL_OBJ_GET_SIZE(symbol)) % bucket_size; diff --git a/lib/hcl.c b/lib/hcl.c index 27f7020..9362d27 100644 --- a/lib/hcl.c +++ b/lib/hcl.c @@ -129,6 +129,11 @@ int hcl_init (hcl_t* hcl, hcl_mmgr_t* mmgr, hcl_oow_t heapsz, const hcl_vmprim_t fill_bigint_tables (hcl); + hcl->tagged_brands[HCL_OOP_TAG_SMOOI] = HCL_BRAND_SMOOI; + hcl->tagged_brands[HCL_OOP_TAG_SMPTR] = HCL_BRAND_SMPTR; + hcl->tagged_brands[HCL_OOP_TAG_CHAR] = HCL_BRAND_CHARACTER; + hcl->tagged_brands[HCL_OOP_TAG_ERROR] = HCL_BRAND_ERROR; + hcl->proc_map_free_first = -1; hcl->proc_map_free_last = -1; diff --git a/lib/hcl.h b/lib/hcl.h index 608948a..9491b80 100644 --- a/lib/hcl.h +++ b/lib/hcl.h @@ -648,23 +648,12 @@ struct hcl_process_scheduler_t hcl_oop_process_t runnable_tail; /* runnable process list */ }; -/** - * The HCL_CLASSOF() macro return the class of an object including a numeric - * object encoded into a pointer. - */ -#define HCL_CLASSOF(hcl,oop) ( \ - HCL_OOP_IS_SMOOI(oop)? (hcl)->_small_integer: \ - HCL_OOP_IS_CHAR(oop)? (hcl)->_character: HCL_OBJ_GET_CLASS(oop) \ -) - /** * The HCL_BRANDOF() macro return the brand of an object including a numeric * object encoded into a pointer. */ -#define HCL_BRANDOF(hcl,oop) ( \ - HCL_OOP_IS_SMOOI(oop)? HCL_BRAND_SMOOI: \ - HCL_OOP_IS_CHAR(oop)? HCL_BRAND_CHARACTER: HCL_OBJ_GET_FLAGS_BRAND(oop) \ -) +#define HCL_BRANDOF(moo,oop) \ + (HCL_OOP_GET_TAG(oop)? ((hcl)->tagged_brands[HCL_OOP_GET_TAG(oop)]): HCL_OBJ_GET_FLAGS_BRAND(oop)) /** * The HCL_BYTESOF() macro returns the size of the payload of @@ -674,6 +663,7 @@ struct hcl_process_scheduler_t #define HCL_BYTESOF(hcl,oop) \ (HCL_OOP_IS_NUMERIC(oop)? HCL_SIZEOF(hcl_oow_t): HCL_OBJ_BYTESOF(oop)) + /** * The HCL_ISTYPEOF() macro is a safe replacement for HCL_OBJ_GET_FLAGS_TYPE() */ @@ -1030,6 +1020,11 @@ struct hcl_t hcl_ooi_t proc_map_free_first; hcl_ooi_t proc_map_free_last; + /* 2 tag bits(lo) + 2 extended tag bits(hi). not all slots are used + * because the 2 high extended bits are used only if the low tag bits + * are 3 */ + int tagged_brands[16]; + /* == EXECUTION REGISTERS == */ hcl_oop_context_t initial_context; /* fake initial context */ hcl_oop_context_t active_context; @@ -1222,11 +1217,15 @@ typedef enum hcl_log_mask_t hcl_log_mask_t; * ========================================================================= */ enum hcl_brand_t { - HCL_BRAND_NIL = 1, + HCL_BRAND_SMOOI = 1, /* never used as a small integer is encoded in an object pointer */ + HCL_BRAND_SMPTR, + HCL_BRAND_ERROR, + HCL_BRAND_CHARACTER, + + HCL_BRAND_NIL, HCL_BRAND_TRUE, HCL_BRAND_FALSE, - HCL_BRAND_CHARACTER, - HCL_BRAND_SMOOI, /* never used as a small integer is encoded in an object pointer */ + HCL_BRAND_PBIGINT, /* positive big integer */ HCL_BRAND_NBIGINT, /* negative big integer */ HCL_BRAND_CONS, diff --git a/lib/obj.c b/lib/obj.c index 392fdef..3463cb3 100644 --- a/lib/obj.c +++ b/lib/obj.c @@ -341,11 +341,11 @@ hcl_oow_t hcl_countcons (hcl_t* hcl, hcl_oop_t cons) /* this function ignores the last cdr */ hcl_oow_t count = 1; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl, cons)); + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons)); do { cons = HCL_CONS_CDR(cons); - if (HCL_BRANDOF(hcl, cons) != HCL_BRAND_CONS) break; + if (!HCL_IS_CONS(hcl, cons)) break; count++; } while (1); @@ -355,11 +355,11 @@ hcl_oow_t hcl_countcons (hcl_t* hcl, hcl_oop_t cons) hcl_oop_t hcl_getlastconscdr (hcl_t* hcl, hcl_oop_t cons) { - HCL_ASSERT (hcl, HCL_BRANDOF(hcl, cons)); + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons)); do { cons = HCL_CONS_CDR(cons); - if (HCL_BRANDOF(hcl, cons) != HCL_BRAND_CONS) break; + if (!HCL_IS_CONS(hcl, cons)) break; } while (1); @@ -373,7 +373,7 @@ hcl_oop_t hcl_reversecons (hcl_t* hcl, hcl_oop_t cons) /* Note: The non-nil cdr in the last cons cell gets lost. * e.g.) Reversing (1 2 3 . 4) results in (3 2 1) */ - HCL_ASSERT (hcl, HCL_BRANDOF(hcl, cons)); + HCL_ASSERT (hcl, HCL_IS_CONS(hcl, cons)); prev = hcl->_nil; ptr = cons; @@ -383,7 +383,7 @@ hcl_oop_t hcl_reversecons (hcl_t* hcl, hcl_oop_t cons) next = HCL_CONS_CDR(ptr); HCL_CONS_CDR(ptr) = prev; prev = ptr; - if (HCL_BRANDOF(hcl,next) != HCL_BRAND_CONS) break; + if (!HCL_IS_CONS(hcl, next)) break; ptr = next; } while (1); diff --git a/lib/prim.c b/lib/prim.c index ba0a8e6..dee11a2 100644 --- a/lib/prim.c +++ b/lib/prim.c @@ -196,6 +196,21 @@ static hcl_pfrc_t pf_eql (hcl_t* hcl, hcl_ooi_t nargs) return HCL_PF_SUCCESS; } +static hcl_pfrc_t pf_eqk (hcl_t* hcl, hcl_ooi_t nargs) +{ + /* equal kind? */ + hcl_oop_t a0, a1, rv; + + a0 = HCL_STACK_GETARG(hcl, nargs, 0); + a1 = HCL_STACK_GETARG(hcl, nargs, 1); + + rv = (HCL_BRANDOF(hcl, a0) == HCL_BRANDOF(hcl, a1)? hcl->_true: hcl->_false); + + HCL_STACK_SETRET (hcl, nargs, rv); + return HCL_PF_SUCCESS; +} + + static hcl_pfrc_t pf_not (hcl_t* hcl, hcl_ooi_t nargs) { hcl_oop_t arg, rv; @@ -381,6 +396,7 @@ static pf_t builtin_prims[] = { 2, 2, pf_eqv, 4, { 'e','q','v','?' } }, { 2, 2, pf_eql, 4, { 'e','q','l','?' } }, + { 2, 2, pf_eqk, 4, { 'e','q','k','?' } }, /* { 2, 2, pf_gt, 1, { '>' } }, diff --git a/lib/print.c b/lib/print.c index 8817cab..1516fc9 100644 --- a/lib/print.c +++ b/lib/print.c @@ -176,32 +176,29 @@ int hcl_outfmtobj (hcl_t* hcl, hcl_oow_t mask, hcl_oop_t obj, hcl_outbfmt_t outb int word_index; next: - if (HCL_OOP_IS_SMOOI(obj)) - { - if (outbfmt(hcl, mask, "%zd", HCL_OOP_TO_SMOOI(obj)) <= -1) return -1; - goto done; - } - else if (HCL_OOP_IS_SMPTR(obj)) - { - if (outbfmt(hcl, mask, "#\\p%zX", (hcl_oow_t)HCL_OOP_TO_SMPTR(obj)) <= -1) return -1; - goto done; - } - else if (HCL_OOP_IS_CHAR(obj)) - { - hcl_ooch_t ch = HCL_OOP_TO_CHAR(obj); - if (outbfmt(hcl, mask, "\'") <= -1 || - print_single_char(hcl, mask, ch, outbfmt) <= -1 || - outbfmt(hcl, mask, "\'") <= -1) return -1; - goto done; - } - else if (HCL_OOP_IS_ERROR(obj)) - { - if (outbfmt(hcl, mask, "#\\e%zd", (hcl_ooi_t)HCL_OOP_TO_ERROR(obj)) <= -1) return -1; - goto done; - } - - switch ((brand = HCL_OBJ_GET_FLAGS_BRAND(obj))) + switch ((brand = HCL_BRANDOF(hcl, obj))) { + case HCL_BRAND_SMOOI: + if (outbfmt(hcl, mask, "%zd", HCL_OOP_TO_SMOOI(obj)) <= -1) return -1; + goto done; + + case HCL_BRAND_SMPTR: + if (outbfmt(hcl, mask, "#\\p%zX", (hcl_oow_t)HCL_OOP_TO_SMPTR(obj)) <= -1) return -1; + goto done; + + case HCL_BRAND_ERROR: + if (outbfmt(hcl, mask, "#\\e%zd", (hcl_ooi_t)HCL_OOP_TO_ERROR(obj)) <= -1) return -1; + goto done; + + case HCL_BRAND_CHARACTER: + { + hcl_ooch_t ch = HCL_OOP_TO_CHAR(obj); + if (outbfmt(hcl, mask, "\'") <= -1 || + print_single_char(hcl, mask, ch, outbfmt) <= -1 || + outbfmt(hcl, mask, "\'") <= -1) return -1; + goto done; + } + case HCL_BRAND_NIL: word_index = WORD_NIL; goto print_word; @@ -214,12 +211,6 @@ next: word_index = WORD_FALSE; goto print_word; - case HCL_BRAND_SMOOI: - /* this type should not appear here as the actual small integer is - * encoded in an object pointer */ - hcl_seterrbfmt (hcl, HCL_EINTERN, "internal error - unexpected object type %d", (int)brand); - return -1; - case HCL_BRAND_PBIGINT: case HCL_BRAND_NBIGINT: { diff --git a/lib/sym.c b/lib/sym.c index 6dc61b8..9fe1ec6 100644 --- a/lib/sym.c +++ b/lib/sym.c @@ -70,7 +70,7 @@ static hcl_oop_oop_t expand_bucket (hcl_t* hcl, hcl_oop_oop_t oldbuc) symbol = (hcl_oop_char_t)oldbuc->slot[--oldsz]; if ((hcl_oop_t)symbol != hcl->_nil) { - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,symbol) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, symbol)); /*HCL_ASSERT (hcl, sym->size > 0);*/ index = hcl_hashoochars(symbol->slot, HCL_OBJ_GET_SIZE(symbol)) % newsz; @@ -96,14 +96,14 @@ static hcl_oop_t find_or_make_symbol (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow return HCL_NULL; } - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,hcl->symtab->bucket) == HCL_BRAND_ARRAY); + HCL_ASSERT (hcl, HCL_IS_ARRAY(hcl, hcl->symtab->bucket)); index = hcl_hashoochars(ptr, len) % HCL_OBJ_GET_SIZE(hcl->symtab->bucket); /* find a matching symbol in the open-addressed symbol table */ while (hcl->symtab->bucket->slot[index] != hcl->_nil) { symbol = (hcl_oop_char_t)hcl->symtab->bucket->slot[index]; - HCL_ASSERT (hcl, HCL_BRANDOF(hcl,symbol) == HCL_BRAND_SYMBOL); + HCL_ASSERT (hcl, HCL_IS_SYMBOL(hcl, symbol)); if (len == HCL_OBJ_GET_SIZE(symbol) && hcl_equaloochars (ptr, symbol->slot, len)) @@ -140,8 +140,8 @@ static hcl_oop_t find_or_make_symbol (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow hcl_oop_oop_t bucket; /* TODO: make the growth policy configurable instead of growing - it just before it gets full. The polcy can be grow it - if it's 70% full */ + it just before it gets full. The polcy can be grow it + if it's 70% full */ /* enlarge the symbol table before it gets full to * make sure that it has at least one free slot left