hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

enhanced HCL_BRANDOF() to avoid multiple comparisons.

Browse Source 
added the eqk? builtin primitive
removed unnecessary lines
This commit is contained in:
hyung-hwan 2018-02-23 07:17:23 +00:00
parent 9abb389aa2
commit 9498530691
8 changed files with 72 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
lib/comp.c
View File

@ -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))
{

2
lib/gc.c
View File

@ -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;

5
lib/hcl.c
View File

@ -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;

31
lib/hcl.h
View File

@ -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,

12
lib/obj.c
View File

@ -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);

16
lib/prim.c
View File

@ -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, { '>' } },

53
lib/print.c
View File

@ -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:
{

10
lib/sym.c
View File

@ -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