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

adding some work-in-progress code to store debugging information for generated byte codes

Browse Source
This commit is contained in:
hyung-hwan 2021-01-03 13:51:23 +00:00
parent 2c49ebe558
commit 6720640ed7
10 changed files with 590 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

269
lib/comp.c
View File

@ -36,10 +36,10 @@ enum
#define BLK_INFO_BUFFER_ALIGN 128 #define BLK_INFO_BUFFER_ALIGN 128
#define EMIT_BYTE_INSTRUCTION(hcl,code) \ #define EMIT_BYTE_INSTRUCTION(hcl,code) \
do { if (emit_byte_instruction(hcl,code) <= -1) return -1; } while(0) do { if (emit_byte_instruction(hcl, code, HCL_NULL) <= -1) return -1; } while(0)
#define EMIT_SINGLE_PARAM_INSTRUCTION(hcl,code) \ #define EMIT_SINGLE_PARAM_INSTRUCTION(hcl,code) \
do { if (emit_byte_instruction(hcl,code) <= -1) return -1; } while(0) do { if (emit_byte_instruction(hcl, code, HCL_NULL) <= -1) return -1; } while(0)
/* -------------------------------------------- /* --------------------------------------------
@ -193,7 +193,7 @@ static HCL_INLINE void patch_instruction (hcl_t* hcl, hcl_oow_t index, hcl_oob_t
hcl->code.bc.ptr[index] = bc; hcl->code.bc.ptr[index] = bc;
} }
static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc) static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc, const hcl_ioloc_t* srcloc)
{ {
/* the context object has the ip field. it should be representable /* the context object has the ip field. it should be representable
* in a small integer. for simplicity, limit the total byte code length * in a small integer. for simplicity, limit the total byte code length
@ -208,24 +208,41 @@ static int emit_byte_instruction (hcl_t* hcl, hcl_oob_t bc)
if (hcl->code.bc.len >= hcl->code.bc.capa) if (hcl->code.bc.len >= hcl->code.bc.capa)
{ {
hcl_oob_t* tmp;
hcl_oow_t newcapa; hcl_oow_t newcapa;
hcl_oob_t* tmp;
hcl_oow_t* tmp2;
newcapa = HCL_ALIGN(hcl->code.bc.capa + 1, HCL_BC_BUFFER_ALIGN); newcapa = HCL_ALIGN(hcl->code.bc.capa + 1, HCL_BC_BUFFER_ALIGN);
tmp = hcl_reallocmem(hcl, hcl->code.bc.ptr, HCL_SIZEOF(*tmp) * newcapa); tmp = (hcl_oob_t*)hcl_reallocmem(hcl, hcl->code.bc.ptr, HCL_SIZEOF(*tmp) * newcapa);
if (!tmp) return -1; if (HCL_UNLIKELY(!tmp)) return -1;
tmp2 = (hcl_oow_t*)hcl_reallocmem(hcl, hcl->code.locptr, HCL_SIZEOF(*tmp2) * newcapa);
if (HCL_UNLIKELY(!tmp2))
{
hcl_freemem (hcl, tmp);
return -1;
}
HCL_MEMSET (&tmp2[hcl->code.bc.capa], 0, HCL_SIZEOF(*tmp2) * (newcapa - hcl->code.bc.capa));
hcl->code.bc.ptr = tmp; hcl->code.bc.ptr = tmp;
hcl->code.bc.capa = newcapa; hcl->code.bc.capa = newcapa;
hcl->code.locptr = tmp2;
} }
hcl->code.bc.ptr[hcl->code.bc.len++] = bc; hcl->code.bc.ptr[hcl->code.bc.len] = bc;
if (srcloc)
{
hcl->code.locptr[hcl->code.bc.len] = srcloc->line;
}
hcl->code.bc.len++;
return 0; return 0;
} }
int hcl_emitbyteinstruction (hcl_t* hcl, hcl_oob_t bc) int hcl_emitbyteinstruction (hcl_t* hcl, hcl_oob_t bc)
{ {
return emit_byte_instruction(hcl, bc); return emit_byte_instruction(hcl, bc, HCL_NULL);
} }
static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1) static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1)
@ -313,7 +330,7 @@ static int emit_single_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
return -1; return -1;
write_short: write_short:
if (emit_byte_instruction(hcl, bc) <= -1) return -1; if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1) return -1;
return 0; return 0;
write_long: write_long:
@ -323,12 +340,12 @@ write_long:
return -1; return -1;
} }
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) #if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF) <= -1 || emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1 & 0xFF) <= -1) return -1; emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1) return -1;
#else #else
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1) <= -1) return -1; emit_byte_instruction(hcl, param_1, HCL_NULL) <= -1) return -1;
#endif #endif
return 0; return 0;
@ -339,15 +356,15 @@ write_long2:
return -1; return -1;
} }
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) #if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, (param_1 >> 24) & 0xFF) <= -1 || emit_byte_instruction(hcl, (param_1 >> 24) & 0xFF, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, (param_1 >> 16) & 0xFF) <= -1 || emit_byte_instruction(hcl, (param_1 >> 16) & 0xFF, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF) <= -1 || emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1 & 0xFF) <= -1) return -1; emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1) return -1;
#else #else
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF) <= -1 || emit_byte_instruction(hcl, (param_1 >> 8) & 0xFF, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1 & 0xFF) <= -1) return -1; emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1) return -1;
#endif #endif
return 0; return 0;
} }
@ -379,8 +396,12 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
goto write_long; goto write_long;
} }
/* MAKE_FUNCTION is a quad-parameter instruction.
case HCL_CODE_MAKE_FUNCTION: /* this is quad-param instruction. you should emit two more parameters after the call to this function */ * The caller must emit two more parameters after the call to this function.
* however the instruction format is the same up to the second
* parameters between MAKE_FUNCTION and MAKE_BLOCK.
*/
case HCL_CODE_MAKE_FUNCTION:
case HCL_CODE_MAKE_BLOCK: case HCL_CODE_MAKE_BLOCK:
bc = cmd; bc = cmd;
goto write_long; goto write_long;
@ -390,8 +411,8 @@ static int emit_double_param_instruction (hcl_t* hcl, int cmd, hcl_oow_t param_1
return -1; return -1;
write_short: write_short:
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_2) <= -1) return -1; emit_byte_instruction(hcl, param_2, HCL_NULL) <= -1) return -1;
return 0; return 0;
write_long: write_long:
@ -401,15 +422,15 @@ write_long:
return -1; return -1;
} }
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) #if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1 >> 8) <= -1 || emit_byte_instruction(hcl, param_1 >> 8, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1 & 0xFF) <= -1 || emit_byte_instruction(hcl, param_1 & 0xFF, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_2 >> 8) <= -1 || emit_byte_instruction(hcl, param_2 >> 8, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_2 & 0xFF) <= -1) return -1; emit_byte_instruction(hcl, param_2 & 0xFF, HCL_NULL) <= -1) return -1;
#else #else
if (emit_byte_instruction(hcl, bc) <= -1 || if (emit_byte_instruction(hcl, bc, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_1) <= -1 || emit_byte_instruction(hcl, param_1, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param_2) <= -1) return -1; emit_byte_instruction(hcl, param_2, HCL_NULL) <= -1) return -1;
#endif #endif
return 0; return 0;
} }
@ -423,10 +444,10 @@ static HCL_INLINE int emit_long_param (hcl_t* hcl, hcl_oow_t param)
} }
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) #if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
return (emit_byte_instruction(hcl, param >> 8) <= -1 || return (emit_byte_instruction(hcl, param >> 8, HCL_NULL) <= -1 ||
emit_byte_instruction(hcl, param & 0xFF) <= -1)? -1: 0; emit_byte_instruction(hcl, param & 0xFF, HCL_NULL) <= -1)? -1: 0;
#else #else
return emit_byte_instruction(hcl, param_1); return emit_byte_instruction(hcl, param_1, HCL_NULL);
#endif #endif
} }
@ -442,16 +463,16 @@ static int emit_push_literal (hcl_t* hcl, hcl_oop_t obj)
switch (i) switch (i)
{ {
case -1: case -1:
return emit_byte_instruction(hcl, HCL_CODE_PUSH_NEGONE); return emit_byte_instruction(hcl, HCL_CODE_PUSH_NEGONE, HCL_NULL);
case 0: case 0:
return emit_byte_instruction(hcl, HCL_CODE_PUSH_ZERO); return emit_byte_instruction(hcl, HCL_CODE_PUSH_ZERO, HCL_NULL);
case 1: case 1:
return emit_byte_instruction(hcl, HCL_CODE_PUSH_ONE); return emit_byte_instruction(hcl, HCL_CODE_PUSH_ONE, HCL_NULL);
case 2: case 2:
return emit_byte_instruction(hcl, HCL_CODE_PUSH_TWO); return emit_byte_instruction(hcl, HCL_CODE_PUSH_TWO, HCL_NULL);
} }
if (i >= 0 && i <= MAX_CODE_PARAM) if (i >= 0 && i <= MAX_CODE_PARAM)
@ -657,6 +678,7 @@ enum
COP_COMPILE_ARRAY_LIST, COP_COMPILE_ARRAY_LIST,
COP_COMPILE_BYTEARRAY_LIST, COP_COMPILE_BYTEARRAY_LIST,
COP_COMPILE_DIC_LIST, COP_COMPILE_DIC_LIST,
COP_COMPILE_QLIST, /* compile data list */
COP_SUBCOMPILE_ELIF, COP_SUBCOMPILE_ELIF,
COP_SUBCOMPILE_ELSE, COP_SUBCOMPILE_ELSE,
@ -666,9 +688,11 @@ enum
COP_EMIT_MAKE_ARRAY, COP_EMIT_MAKE_ARRAY,
COP_EMIT_MAKE_BYTEARRAY, COP_EMIT_MAKE_BYTEARRAY,
COP_EMIT_MAKE_DIC, COP_EMIT_MAKE_DIC,
COP_EMIT_MAKE_DLIST,
COP_EMIT_POP_INTO_ARRAY, COP_EMIT_POP_INTO_ARRAY,
COP_EMIT_POP_INTO_BYTEARRAY, COP_EMIT_POP_INTO_BYTEARRAY,
COP_EMIT_POP_INTO_DIC, COP_EMIT_POP_INTO_DIC,
COP_EMIT_POP_INTO_DLIST,
COP_EMIT_LAMBDA, COP_EMIT_LAMBDA,
COP_EMIT_POP_STACKTOP, COP_EMIT_POP_STACKTOP,
@ -800,7 +824,7 @@ static int compile_break (hcl_t* hcl, hcl_oop_t src)
* function call, i generate PUSH_NIL so nil becomes a return value. * function call, i generate PUSH_NIL so nil becomes a return value.
* (set x (until #f (break))) * (set x (until #f (break)))
* x will get nill. */ * x will get nill. */
if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1;
/* TODO: study if supporting expression after break is good like return. (break (+ 10 20)) */ /* TODO: study if supporting expression after break is good like return. (break (+ 10 20)) */
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
@ -1072,8 +1096,8 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun)
/* make_function nargs ntmprs lfbase lfsize */ /* make_function nargs ntmprs lfbase lfsize */
if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_FUNCTION, nargs, ntmprs) <= -1) return -1; if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_FUNCTION, nargs, ntmprs) <= -1) return -1;
lfbase_pos = hcl->code.bc.len; lfbase_pos = hcl->code.bc.len;
if (emit_long_param(hcl, hcl->code.lit.len - hcl->c->blk.info[hcl->c->blk.depth - 1].lfbase) <= -1) return -1; /* lfbase */ if (emit_long_param(hcl, hcl->code.lit.len - hcl->c->blk.info[hcl->c->blk.depth - 1].lfbase) <= -1) return -1; /* literal frame base */
lfsize_pos = hcl->code.bc.len; lfsize_pos = hcl->code.bc.len; /* literal frame size */
if (emit_long_param(hcl, 0) <= -1) return -1; if (emit_long_param(hcl, 0) <= -1) return -1;
} }
else else
@ -1408,6 +1432,40 @@ static int compile_cons_dic_expression (hcl_t* hcl, hcl_oop_t obj)
return 0; return 0;
} }
static int compile_cons_qlist_expression (hcl_t* hcl, hcl_oop_t obj)
{
/* #( 1 2 3 )
* #(1 (+ 2 3) 5)
* */
hcl_ooi_t nargs;
hcl_cframe_t* cf;
/* NOTE: cframe management functions don't use the object memory.
* many operations can be performed without taking GC into account */
SWITCH_TOP_CFRAME (hcl, COP_EMIT_MAKE_DLIST, HCL_SMOOI_TO_OOP(0));
nargs = hcl_countcons(hcl, obj);
if (nargs > MAX_CODE_PARAM)
{
/* TODO: change to syntax error */
hcl_setsynerrbfmt (hcl, HCL_SYNERR_ARGFLOOD, HCL_NULL, HCL_NULL, "too many(%zd) elements into array - %O", nargs, obj);
return -1;
}
/* redundant cdr check is performed inside compile_object_list() */
PUSH_SUBCFRAME (hcl, COP_COMPILE_QLIST, obj);
cf = GET_SUBCFRAME(hcl);
/* cf->u.qlist.index = 0;*/
/* patch the argument count in the operand field of the COP_EMIT_MAKE_ARRAY frame */
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DLIST);
cf->operand = HCL_SMOOI_TO_OOP(nargs);
return 0;
}
static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj) static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
{ {
hcl_oop_t car; hcl_oop_t car;
@ -1697,7 +1755,10 @@ static int compile_object (hcl_t* hcl)
if (compile_cons_dic_expression(hcl, cf->operand) <= -1) return -1; if (compile_cons_dic_expression(hcl, cf->operand) <= -1) return -1;
break; break;
/* TODO: QLIST? */ case HCL_CONCODE_QLIST:
if (compile_cons_qlist_expression(hcl, cf->operand) <= -1) return -1;
break;
default: default:
if (compile_cons_xlist_expression(hcl, cf->operand) <= -1) return -1; if (compile_cons_xlist_expression(hcl, cf->operand) <= -1) return -1;
break; break;
@ -1980,6 +2041,53 @@ static int compile_dic_list (hcl_t* hcl)
return 0; return 0;
} }
static int compile_qlist (hcl_t* hcl)
{
hcl_cframe_t* cf;
hcl_oop_t coperand;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_COMPILE_QLIST);
coperand = cf->operand;
if (HCL_IS_NIL(hcl, coperand))
{
POP_CFRAME (hcl);
}
else
{
hcl_oop_t car, cdr;
hcl_ooi_t oldidx;
if (!HCL_IS_CONS(hcl, coperand))
{
hcl_setsynerrbfmt (
hcl, HCL_SYNERR_DOTBANNED, HCL_NULL, HCL_NULL,
"redundant cdr in the qlist list - %O", coperand); /* TODO: error location */
return -1;
}
car = HCL_CONS_CAR(coperand);
cdr = HCL_CONS_CDR(coperand);
/*oldidx = cf->u.qlist.index;*/
SWITCH_TOP_CFRAME (hcl, COP_COMPILE_OBJECT, car);
if (!HCL_IS_NIL(hcl, cdr))
{
PUSH_SUBCFRAME (hcl, COP_COMPILE_QLIST, cdr);
cf = GET_SUBCFRAME(hcl);
/*cf->u.qlist_list.index = oldidx + 1;*/
}
PUSH_SUBCFRAME (hcl, COP_EMIT_POP_INTO_DLIST, HCL_SMOOI_TO_OOP(oldidx));
}
return 0;
}
/* ========================================================================= */ /* ========================================================================= */
static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl) static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl)
@ -1997,7 +2105,7 @@ static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl)
if (hcl->code.bc.len <= cf->u.post_if.body_pos) if (hcl->code.bc.len <= cf->u.post_if.body_pos)
{ {
/* the if body is empty. */ /* the if body is empty. */
if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1;
} }
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
@ -2021,7 +2129,7 @@ static HCL_INLINE int patch_nearest_post_if_body (hcl_t* hcl)
/* beginning of the elif/else block code */ /* beginning of the elif/else block code */
/* to drop the result of the conditional when the conditional is false */ /* to drop the result of the conditional when the conditional is false */
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
/* this is the actual beginning */ /* this is the actual beginning */
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
@ -2132,7 +2240,7 @@ static HCL_INLINE int subcompile_and_expr (hcl_t* hcl)
jump_inst_pos = hcl->code.bc.len; jump_inst_pos = hcl->code.bc.len;
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1; if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
expr = HCL_CONS_CAR(obj); expr = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj); obj = HCL_CONS_CDR(obj);
@ -2199,7 +2307,7 @@ static HCL_INLINE int subcompile_or_expr (hcl_t* hcl)
jump_inst_pos = hcl->code.bc.len; jump_inst_pos = hcl->code.bc.len;
if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_TRUE, MAX_CODE_JUMP) <= -1) return -1; if (emit_single_param_instruction(hcl, HCL_CODE_JUMP_FORWARD_IF_TRUE, MAX_CODE_JUMP) <= -1) return -1;
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
expr = HCL_CONS_CAR(obj); expr = HCL_CONS_CAR(obj);
obj = HCL_CONS_CDR(obj); obj = HCL_CONS_CDR(obj);
@ -2252,7 +2360,7 @@ static HCL_INLINE int post_if_cond (hcl_t* hcl)
if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1; if (emit_single_param_instruction (hcl, HCL_CODE_JUMP_FORWARD_IF_FALSE, MAX_CODE_JUMP) <= -1) return -1;
/* to drop the result of the conditional when it is true */ /* to drop the result of the conditional when it is true */
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
body_pos = hcl->code.bc.len; body_pos = hcl->code.bc.len;
@ -2279,7 +2387,7 @@ static HCL_INLINE int post_if_body (hcl_t* hcl)
if (hcl->code.bc.len <= cf->u.post_if.body_pos) if (hcl->code.bc.len <= cf->u.post_if.body_pos)
{ {
/* if body is empty */ /* if body is empty */
if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1;
} }
/* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE instruction */ /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD_IF_FALSE instruction */
@ -2324,7 +2432,7 @@ static HCL_INLINE int post_while_cond (hcl_t* hcl)
} }
if (emit_single_param_instruction (hcl, jump_inst, MAX_CODE_JUMP) <= -1) return -1; if (emit_single_param_instruction (hcl, jump_inst, MAX_CODE_JUMP) <= -1) return -1;
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
body_pos = hcl->code.bc.len; body_pos = hcl->code.bc.len;
@ -2359,7 +2467,7 @@ static HCL_INLINE int post_while_body (hcl_t* hcl)
* pop_stacktop * pop_stacktop
* this check prevents another pop_stacktop between 1) and 2) * this check prevents another pop_stacktop between 1) and 2)
*/ */
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) return -1; if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) return -1;
} }
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX);
@ -2470,6 +2578,21 @@ static HCL_INLINE int emit_make_dic (hcl_t* hcl)
return n; return n;
} }
static HCL_INLINE int emit_make_dlist (hcl_t* hcl)
{
hcl_cframe_t* cf;
int n;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_MAKE_DLIST);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand));
n = emit_single_param_instruction (hcl, HCL_CODE_MAKE_DLIST, HCL_OOP_TO_SMOOI(cf->operand));
POP_CFRAME (hcl);
return n;
}
static HCL_INLINE int emit_pop_into_array (hcl_t* hcl) static HCL_INLINE int emit_pop_into_array (hcl_t* hcl)
{ {
hcl_cframe_t* cf; hcl_cframe_t* cf;
@ -2508,7 +2631,22 @@ static HCL_INLINE int emit_pop_into_dic (hcl_t* hcl)
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DIC); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DIC);
n = emit_byte_instruction (hcl, HCL_CODE_POP_INTO_DIC); n = emit_byte_instruction (hcl, HCL_CODE_POP_INTO_DIC, HCL_NULL);
POP_CFRAME (hcl);
return n;
}
static HCL_INLINE int emit_pop_into_dlist (hcl_t* hcl)
{
hcl_cframe_t* cf;
int n;
cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_INTO_DLIST);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand));
n = emit_single_param_instruction (hcl, HCL_CODE_POP_INTO_DLIST, HCL_OOP_TO_SMOOI(cf->operand));
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -2539,11 +2677,11 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
{ {
/* no body in lambda - (lambda (a b c)) */ /* no body in lambda - (lambda (a b c)) */
/* TODO: is this correct??? */ /* TODO: is this correct??? */
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL) <= -1) return -1; if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL, HCL_NULL) <= -1) return -1;
block_code_size++; block_code_size++;
} }
if (emit_byte_instruction(hcl, HCL_CODE_RETURN_FROM_BLOCK) <= -1) return -1; if (emit_byte_instruction(hcl, HCL_CODE_RETURN_FROM_BLOCK, HCL_NULL) <= -1) return -1;
block_code_size++; block_code_size++;
if (block_code_size > MAX_CODE_JUMP * 2) if (block_code_size > MAX_CODE_JUMP * 2)
@ -2570,7 +2708,7 @@ static HCL_INLINE int emit_pop_stacktop (hcl_t* hcl)
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_STACKTOP); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_POP_STACKTOP);
HCL_ASSERT (hcl, HCL_IS_NIL(hcl, cf->operand)); HCL_ASSERT (hcl, HCL_IS_NIL(hcl, cf->operand));
n = emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP); n = emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL);
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -2585,7 +2723,7 @@ static HCL_INLINE int emit_return (hcl_t* hcl)
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_RETURN); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_RETURN);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand)); HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(cf->operand));
n = emit_byte_instruction(hcl, (HCL_OOP_TO_SMOOI(cf->operand) == 0? HCL_CODE_RETURN_FROM_BLOCK: HCL_CODE_RETURN_STACKTOP)); n = emit_byte_instruction(hcl, (HCL_OOP_TO_SMOOI(cf->operand) == 0? HCL_CODE_RETURN_FROM_BLOCK: HCL_CODE_RETURN_STACKTOP), HCL_NULL);
POP_CFRAME (hcl); POP_CFRAME (hcl);
return n; return n;
@ -2632,7 +2770,6 @@ static HCL_INLINE int emit_set (hcl_t* hcl)
/* ========================================================================= */ /* ========================================================================= */
int hcl_compile (hcl_t* hcl, hcl_oop_t obj) int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
{ {
hcl_oow_t saved_bc_len, saved_lit_len; hcl_oow_t saved_bc_len, saved_lit_len;
@ -2720,6 +2857,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (compile_dic_list(hcl) <= -1) goto oops; if (compile_dic_list(hcl) <= -1) goto oops;
break; break;
case COP_COMPILE_QLIST:
if (compile_qlist(hcl) <= -1) goto oops;
break;
case COP_EMIT_CALL: case COP_EMIT_CALL:
if (emit_call(hcl) <= -1) goto oops; if (emit_call(hcl) <= -1) goto oops;
break; break;
@ -2736,6 +2877,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (emit_make_dic(hcl) <= -1) goto oops; if (emit_make_dic(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_MAKE_DLIST:
if (emit_make_dlist(hcl) <= -1) goto oops;
break;
case COP_EMIT_POP_INTO_ARRAY: case COP_EMIT_POP_INTO_ARRAY:
if (emit_pop_into_array(hcl) <= -1) goto oops; if (emit_pop_into_array(hcl) <= -1) goto oops;
break; break;
@ -2744,6 +2889,10 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
if (emit_pop_into_bytearray(hcl) <= -1) goto oops; if (emit_pop_into_bytearray(hcl) <= -1) goto oops;
break; break;
case COP_EMIT_POP_INTO_DLIST:
if (emit_pop_into_dlist(hcl) <= -1) goto oops;
break;
case COP_EMIT_POP_INTO_DIC: case COP_EMIT_POP_INTO_DIC:
if (emit_pop_into_dic(hcl) <= -1) goto oops; if (emit_pop_into_dic(hcl) <= -1) goto oops;
break; break;
@ -2819,7 +2968,7 @@ int hcl_compile (hcl_t* hcl, hcl_oop_t obj)
/* emit the pop instruction to clear the final result */ /* emit the pop instruction to clear the final result */
/* TODO: for interactive use, this value must be accessible by the executor... how to do it? */ /* TODO: for interactive use, this value must be accessible by the executor... how to do it? */
if (emit_byte_instruction (hcl, HCL_CODE_POP_STACKTOP) <= -1) goto oops; if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_NULL) <= -1) goto oops;
HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0); HCL_ASSERT (hcl, GET_TOP_CFRAME_INDEX(hcl) < 0);
HCL_ASSERT (hcl, hcl->c->tv.size == 0); HCL_ASSERT (hcl, hcl->c->tv.size == 0);

197
lib/debug.c
View File

@ -69,3 +69,200 @@ void hcl_dumpdic (hcl_t* hcl, hcl_oop_dic_t dic, const hcl_bch_t* title)
/* TODO: hcl_loaddbgifromimage() -> load debug information from compiled image?
hcl_storedbgitoimage()? -> store debug information to compiled image?
hcl_compactdbgi()? -> compact debug information by scaning dbgi data. find class and method. if not found, drop the portion.
*/
int hcl_initdbgi (hcl_t* hcl, hcl_oow_t capa)
{
hcl_dbgi_t* tmp;
if (capa < HCL_SIZEOF(*tmp)) capa = HCL_SIZEOF(*tmp);
tmp = (hcl_dbgi_t*)hcl_callocmem(hcl, capa);
if (!tmp) return -1;
tmp->_capa = capa;
tmp->_len = HCL_SIZEOF(*tmp);
/* tmp->_last_file = 0;
tmp->_last_class = 0;
tmp->_last_text = 0;
tmp->_last_method = 0; */
hcl->dbgi = tmp;
return 0;
}
void hcl_finidbgi (hcl_t* hcl)
{
if (hcl->dbgi)
{
hcl_freemem (hcl, hcl->dbgi);
hcl->dbgi = HCL_NULL;
}
}
static HCL_INLINE hcl_uint8_t* secure_dbgi_space (hcl_t* hcl, hcl_oow_t req_bytes)
{
if (hcl->dbgi->_capa - hcl->dbgi->_len < req_bytes)
{
hcl_dbgi_t* tmp;
hcl_oow_t newcapa;
newcapa = hcl->dbgi->_len + req_bytes;
newcapa = HCL_ALIGN_POW2(newcapa, 65536); /* TODO: make the align value configurable */
tmp = hcl_reallocmem(hcl, hcl->dbgi, newcapa);
if (!tmp) return HCL_NULL;
hcl->dbgi = tmp;
hcl->dbgi->_capa = newcapa;
}
return &((hcl_uint8_t*)hcl->dbgi)[hcl->dbgi->_len];
}
int hcl_addfiletodbgi (hcl_t* hcl, const hcl_ooch_t* file_name, hcl_oow_t* start_offset)
{
hcl_oow_t name_len, name_bytes, name_bytes_aligned, req_bytes;
hcl_dbgi_file_t* di;
if (!hcl->dbgi)
{
if (start_offset) *start_offset = 0;
return 0; /* debug information is disabled*/
}
if (hcl->dbgi->_last_file > 0)
{
/* TODO: avoid linear search. need indexing for speed up */
hcl_oow_t offset = hcl->dbgi->_last_file;
do
{
di = (hcl_dbgi_file_t*)&((hcl_uint8_t*)hcl->dbgi)[offset];
if (hcl_comp_oocstr((hcl_ooch_t*)(di + 1), file_name) == 0)
{
if (start_offset) *start_offset = offset;
return 0;
}
offset = di->_next;
}
while (offset > 0);
}
name_len = hcl_count_oocstr(file_name);
name_bytes = (name_len + 1) * HCL_SIZEOF(*file_name);
name_bytes_aligned = HCL_ALIGN_POW2(name_bytes, HCL_SIZEOF_OOW_T);
req_bytes = HCL_SIZEOF(hcl_dbgi_file_t) + name_bytes_aligned;
di = (hcl_dbgi_file_t*)secure_dbgi_space(hcl, req_bytes);
if (!di) return -1;
di->_type = HCL_DBGI_MAKE_TYPE(HCL_DBGI_TYPE_CODE_FILE, 0);
di->_len = req_bytes;
di->_next = hcl->dbgi->_last_file;
hcl_copy_oocstr ((hcl_ooch_t*)(di + 1), name_len + 1, file_name);
hcl->dbgi->_last_file = hcl->dbgi->_len;
hcl->dbgi->_len += req_bytes;
if (start_offset) *start_offset = hcl->dbgi->_last_file;
return 0;
}
int hcl_addclasstodbgi (hcl_t* hcl, const hcl_ooch_t* class_name, hcl_oow_t file_offset, hcl_oow_t file_line, hcl_oow_t* start_offset)
{
hcl_oow_t name_len, name_bytes, name_bytes_aligned, req_bytes;
hcl_dbgi_class_t* di;
if (!hcl->dbgi) return 0; /* debug information is disabled*/
if (hcl->dbgi->_last_class > 0)
{
/* TODO: avoid linear search. need indexing for speed up */
hcl_oow_t offset = hcl->dbgi->_last_class;
do
{
di = (hcl_dbgi_class_t*)&((hcl_uint8_t*)hcl->dbgi)[offset];
if (hcl_comp_oocstr((hcl_ooch_t*)(di + 1), class_name) == 0 && di->_file == file_offset && di->_line == file_line)
{
if (start_offset) *start_offset = offset;
return 0;
}
offset = di->_next;
}
while (offset > 0);
}
name_len = hcl_count_oocstr(class_name);
name_bytes = (name_len + 1) * HCL_SIZEOF(*class_name);
name_bytes_aligned = HCL_ALIGN_POW2(name_bytes, HCL_SIZEOF_OOW_T);
req_bytes = HCL_SIZEOF(hcl_dbgi_class_t) + name_bytes_aligned;
di = (hcl_dbgi_class_t*)secure_dbgi_space(hcl, req_bytes);
if (!di) return -1;
di->_type = HCL_DBGI_MAKE_TYPE(HCL_DBGI_TYPE_CODE_CLASS, 0);
di->_len = req_bytes;
di->_next = hcl->dbgi->_last_class;
di->_file = file_offset;
di->_line = file_line;
hcl_copy_oocstr ((hcl_ooch_t*)(di + 1), name_len + 1, class_name);
hcl->dbgi->_last_class = hcl->dbgi->_len;
hcl->dbgi->_len += req_bytes;
if (start_offset) *start_offset = hcl->dbgi->_last_class;
return 0;
}
int hcl_addmethodtodbgi (hcl_t* hcl, hcl_oow_t file_offset, hcl_oow_t class_offset, const hcl_ooch_t* method_name, hcl_oow_t start_line, const hcl_oow_t* code_loc_ptr, hcl_oow_t code_loc_len, const hcl_ooch_t* text_ptr, hcl_oow_t text_len, hcl_oow_t* start_offset)
{
hcl_oow_t name_len, name_bytes, name_bytes_aligned, code_loc_bytes, code_loc_bytes_aligned, text_bytes, text_bytes_aligned, req_bytes;
hcl_dbgi_method_t* di;
hcl_uint8_t* curptr;
if (!hcl->dbgi) return 0; /* debug information is disabled*/
name_len = hcl_count_oocstr(method_name);
name_bytes = (name_len + 1) * HCL_SIZEOF(*method_name);
name_bytes_aligned = HCL_ALIGN_POW2(name_bytes, HCL_SIZEOF_OOW_T);
code_loc_bytes = code_loc_len * HCL_SIZEOF(*code_loc_ptr);
code_loc_bytes_aligned = HCL_ALIGN_POW2(code_loc_bytes, HCL_SIZEOF_OOW_T);
text_bytes = text_len * HCL_SIZEOF(*text_ptr);
text_bytes_aligned = HCL_ALIGN_POW2(text_bytes, HCL_SIZEOF_OOW_T);
req_bytes = HCL_SIZEOF(hcl_dbgi_method_t) + name_bytes_aligned + code_loc_bytes_aligned + text_bytes_aligned;
di = (hcl_dbgi_method_t*)secure_dbgi_space(hcl, req_bytes);
if (HCL_UNLIKELY(!di)) return -1;
di->_type = HCL_DBGI_MAKE_TYPE(HCL_DBGI_TYPE_CODE_METHOD, 0);
di->_len = req_bytes;
di->_next = hcl->dbgi->_last_method;
di->_file = file_offset;
di->_class = class_offset;
di->start_line = start_line;
di->code_loc_start = name_bytes_aligned; /* distance from the beginning of the variable payload */
di->code_loc_len = code_loc_len;
di->text_start = name_bytes_aligned + code_loc_bytes_aligned; /* distance from the beginning of the variable payload */
di->text_len = text_len;
curptr = (hcl_uint8_t*)(di + 1);
hcl_copy_oocstr ((hcl_ooch_t*)curptr, name_len + 1, method_name);
curptr += name_bytes_aligned;
HCL_MEMCPY (curptr, code_loc_ptr, code_loc_bytes);
if (text_len > 0)
{
curptr += code_loc_bytes_aligned;
hcl_copy_oochars ((hcl_ooch_t*)curptr, text_ptr, text_len);
}
hcl->dbgi->_last_method = hcl->dbgi->_len;
hcl->dbgi->_len += req_bytes;
if (start_offset) *start_offset = hcl->dbgi->_last_method;
return 0;
}

8
lib/decode.c
View File

@ -530,6 +530,14 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
LOG_INST_0 (hcl, "pop_into_dic"); LOG_INST_0 (hcl, "pop_into_dic");
break; break;
case HCL_CODE_MAKE_DLIST:
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dlist %zu", b1);
break;
case HCL_CODE_POP_INTO_DLIST:
LOG_INST_0 (hcl, "pop_into_dlist");
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
case HCL_CODE_DUP_STACKTOP: case HCL_CODE_DUP_STACKTOP:

40
lib/exec.c
View File

@ -3192,8 +3192,8 @@ static int execute (hcl_t* hcl)
LOG_INST_1 (hcl, "make_array %zu", b1); LOG_INST_1 (hcl, "make_array %zu", b1);
/* create an empty array */ /* create an empty array */
t = hcl_makearray (hcl, b1, 0); t = hcl_makearray(hcl, b1, 0);
if (!t) goto oops; if (HCL_UNLIKELY(!t)) goto oops;
HCL_STACK_PUSH (hcl, t); /* push the array created */ HCL_STACK_PUSH (hcl, t); /* push the array created */
break; break;
@ -3219,8 +3219,8 @@ static int execute (hcl_t* hcl)
LOG_INST_1 (hcl, "make_bytearray %zu", b1); LOG_INST_1 (hcl, "make_bytearray %zu", b1);
/* create an empty array */ /* create an empty array */
t = hcl_makebytearray (hcl, HCL_NULL, b1); t = hcl_makebytearray(hcl, HCL_NULL, b1);
if (!t) goto oops; if (HCL_UNLIKELY(!t)) goto oops;
HCL_STACK_PUSH (hcl, t); /* push the byte array created */ HCL_STACK_PUSH (hcl, t); /* push the byte array created */
break; break;
@ -3253,8 +3253,8 @@ static int execute (hcl_t* hcl)
FETCH_PARAM_CODE_TO (hcl, b1); FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dic %zu", b1); LOG_INST_1 (hcl, "make_dic %zu", b1);
t = (hcl_oop_t)hcl_makedic (hcl, b1 + 10); t = (hcl_oop_t)hcl_makedic(hcl, b1 + 10);
if (!t) goto oops; if (HCL_UNLIKELY(!t)) goto oops;
HCL_STACK_PUSH (hcl, t); HCL_STACK_PUSH (hcl, t);
break; break;
} }
@ -3269,7 +3269,33 @@ static int execute (hcl_t* hcl)
t2 = HCL_STACK_GETTOP(hcl); /* key */ t2 = HCL_STACK_GETTOP(hcl); /* key */
HCL_STACK_POP (hcl); HCL_STACK_POP (hcl);
t3 = HCL_STACK_GETTOP(hcl); /* dictionary */ t3 = HCL_STACK_GETTOP(hcl); /* dictionary */
if (!hcl_putatdic (hcl, (hcl_oop_dic_t)t3, t2, t1)) goto oops; if (!hcl_putatdic(hcl, (hcl_oop_dic_t)t3, t2, t1)) goto oops;
break;
}
case HCL_CODE_MAKE_DLIST:
{
hcl_oop_t t;
FETCH_PARAM_CODE_TO (hcl, b1);
LOG_INST_1 (hcl, "make_dlist %zu", b1);
/* create an empty array */
t = hcl_makedlist(hcl, b1, 0);
if (HCL_UNLIKELY(!t)) goto oops;
HCL_STACK_PUSH (hcl, t); /* push the list created */
break;
}
case HCL_CODE_POP_INTO_DLIST:
{
hcl_oop_t t1, t2;
LOG_INST_0 (hcl, "pop_into_dlist");
t1 = HCL_STACK_GETTOP(hcl); /* value to store */
HCL_STACK_POP (hcl);
t2 = HCL_STACK_GETTOP(hcl); /* dlist */
/* TODO: append t2 to the dlist */
break; break;
} }

19
lib/gc.c
View File

@ -176,7 +176,7 @@ static HCL_INLINE void gc_ms_mark (hcl_t* hcl, hcl_oop_t oop)
HCL_OBJ_SET_FLAGS_MOVED(oop, 1); /* mark */ HCL_OBJ_SET_FLAGS_MOVED(oop, 1); /* mark */
gc_ms_mark (hcl, (hcl_oop_t)HCL_OBJ_GET_CLASS(oop)); /* TODO: remove recursion */ /*gc_ms_mark (hcl, (hcl_oop_t)HCL_OBJ_GET_CLASS(oop));*/ /* TODO: remove recursion */
if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP) if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP)
{ {
@ -226,7 +226,7 @@ static HCL_INLINE void gc_ms_scan_stack (hcl_t* hcl)
{ {
oop = hcl->gci.stack.ptr[--hcl->gci.stack.len]; oop = hcl->gci.stack.ptr[--hcl->gci.stack.len];
gc_ms_mark_object (hcl, (hcl_oop_t)HCL_OBJ_GET_CLASS(oop)); /*gc_ms_mark_object (hcl, (hcl_oop_t)HCL_OBJ_GET_CLASS(oop));*/
if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP) if (HCL_OBJ_GET_FLAGS_TYPE(oop) == HCL_OBJ_TYPE_OOP)
{ {
@ -811,6 +811,21 @@ int hcl_ignite (hcl_t* hcl)
hcl->code.bc.capa = HCL_BC_BUFFER_INIT; hcl->code.bc.capa = HCL_BC_BUFFER_INIT;
} }
if (!hcl->code.locptr)
{
hcl->code.locptr = (hcl_oow_t*)hcl_allocmem(hcl, HCL_SIZEOF(*hcl->code.locptr) * HCL_BC_BUFFER_INIT);
if (HCL_UNLIKELY(!hcl->code.locptr))
{
/* bc.ptr and locptr go together. so free bc.ptr if locptr allocation fails */
hcl_freemem (hcl, hcl->code.bc.ptr);
hcl->code.bc.ptr = HCL_NULL;
hcl->code.bc.capa = 0;
return -1;
}
HCL_MEMSET (hcl->code.locptr, 0, HCL_SIZEOF(*hcl->code.locptr) * HCL_BC_BUFFER_INIT);
}
/* TODO: move code.lit.arr creation to hcl_init() after swithching to hcl_allocmem? */ /* TODO: move code.lit.arr creation to hcl_init() after swithching to hcl_allocmem? */
if (!hcl->code.lit.arr) if (!hcl->code.lit.arr)
{ {

19
lib/hcl-prv.h
View File

@ -50,7 +50,7 @@
#define HCL_DEBUG_LEXER 1 #define HCL_DEBUG_LEXER 1
#define HCL_DEBUG_VM_PROCESSOR 1 #define HCL_DEBUG_VM_PROCESSOR 1
#define HCL_DEBUG_VM_EXEC 1 #define HCL_DEBUG_VM_EXEC 1
#define HCL_PROFILE_VM 1 /*#define HCL_PROFILE_VM 1*/
#endif #endif
/* allow the caller to drive process switching by calling /* allow the caller to drive process switching by calling
@ -570,7 +570,7 @@ enum hcl_bcode_t
HCL_CODE_PUSH_FALSE = 0x84, /* 132 */ HCL_CODE_PUSH_FALSE = 0x84, /* 132 */
HCL_CODE_PUSH_CONTEXT = 0x85, /* 133 */ HCL_CODE_PUSH_CONTEXT = 0x85, /* 133 */
HCL_CODE_PUSH_PROCESS = 0x86, /* 134 */ HCL_CODE_PUSH_PROCESS = 0x86, /* 134 */
/* UNUSED135 */ /* UNUSED 135 */
HCL_CODE_POP_INTO_INSTVAR_X = 0x88, /* 136 ## */ HCL_CODE_POP_INTO_INSTVAR_X = 0x88, /* 136 ## */
@ -616,16 +616,15 @@ enum hcl_bcode_t
HCL_CODE_STORE_INTO_OBJVAR_X = 0xE8, /* 232 ## */ HCL_CODE_STORE_INTO_OBJVAR_X = 0xE8, /* 232 ## */
HCL_CODE_POP_INTO_OBJVAR_X = 0xEC, /* 236 ## */ HCL_CODE_POP_INTO_OBJVAR_X = 0xEC, /* 236 ## */
/* UNUSED 237 */ HCL_CODE_MAKE_BYTEARRAY = 0xED, /* 237 */
HCL_CODE_MAKE_BYTEARRAY = 0xEE, /* 238 */ HCL_CODE_POP_INTO_BYTEARRAY = 0xEE, /* 238 */
HCL_CODE_POP_INTO_BYTEARRAY = 0xEF, /* 239 */ HCL_CODE_MAKE_DIC = 0xEF, /* 239 */
HCL_CODE_SEND_MESSAGE_X = 0xF0, /* 240 ## */ HCL_CODE_SEND_MESSAGE_X = 0xF0, /* 240 ## */
/* UNUSED 241 */ HCL_CODE_POP_INTO_DIC = 0xF1, /* 241 */
HCL_CODE_MAKE_DLIST = 0xF2, /* 242 */
HCL_CODE_MAKE_DIC = 0xF2, /* 242 */ HCL_CODE_POP_INTO_DLIST = 0xF3, /* 243 */
HCL_CODE_POP_INTO_DIC = 0xF3, /* 243 */
HCL_CODE_SEND_MESSAGE_TO_SUPER_X = 0xF4, /* 244 ## */ HCL_CODE_SEND_MESSAGE_TO_SUPER_X = 0xF4, /* 244 ## */
/* -------------------------------------- */ /* -------------------------------------- */
@ -639,7 +638,7 @@ enum hcl_bcode_t
HCL_CODE_RETURN_RECEIVER = 0xFA, /* ^self */ HCL_CODE_RETURN_RECEIVER = 0xFA, /* ^self */
HCL_CODE_RETURN_FROM_BLOCK = 0xFB, /* return the stack top from a block */ HCL_CODE_RETURN_FROM_BLOCK = 0xFB, /* return the stack top from a block */
HCL_CODE_MAKE_FUNCTION = 0xFC, /* 252 */ HCL_CODE_MAKE_FUNCTION = 0xFC, /* 252 */
HCL_CODE_MAKE_BLOCK = 0xFD, /* 253 */ HCL_CODE_MAKE_BLOCK = 0xFD, /* 253 */
/* UNUSED 254 */ /* UNUSED 254 */
HCL_CODE_NOOP = 0xFF /* 255 */ HCL_CODE_NOOP = 0xFF /* 255 */

7
lib/hcl.c
View File

@ -258,6 +258,12 @@ void hcl_fini (hcl_t* hcl)
hcl->proc_map_free_last = -1; hcl->proc_map_free_last = -1;
} }
if (hcl->code.locptr)
{
hcl_freemem (hcl, hcl->code.locptr);
hcl->code.locptr = HCL_NULL;
}
if (hcl->code.bc.ptr) if (hcl->code.bc.ptr)
{ {
hcl_freemem (hcl, hcl->code.bc.ptr); hcl_freemem (hcl, hcl->code.bc.ptr);
@ -304,6 +310,7 @@ void hcl_fini (hcl_t* hcl)
} }
hcl_killheap (hcl, hcl->heap); hcl_killheap (hcl, hcl->heap);
hcl_finidbgi (hcl);
if (hcl->log.ptr) if (hcl->log.ptr)
{ {

96
lib/hcl.h
View File

@ -384,7 +384,7 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
#define HCL_OBJ_SET_FLAGS_BRAND(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_BRAND_SHIFT, HCL_OBJ_FLAGS_BRAND_BITS, v) #define HCL_OBJ_SET_FLAGS_BRAND(oop,v) HCL_SETBITS(hcl_oow_t, (oop)->_flags, HCL_OBJ_FLAGS_BRAND_SHIFT, HCL_OBJ_FLAGS_BRAND_BITS, v)
#define HCL_OBJ_GET_SIZE(oop) ((oop)->_size) #define HCL_OBJ_GET_SIZE(oop) ((oop)->_size)
#define HCL_OBJ_GET_CLASS(oop) ((oop)->_class) /*#define HCL_OBJ_GET_CLASS(oop) ((oop)->_class)*/
#define HCL_OBJ_SET_SIZE(oop,v) ((oop)->_size = (v)) #define HCL_OBJ_SET_SIZE(oop,v) ((oop)->_size = (v))
#define HCL_OBJ_SET_CLASS(oop,c) ((oop)->_class = (c)) #define HCL_OBJ_SET_CLASS(oop,c) ((oop)->_class = (c))
@ -415,8 +415,7 @@ typedef enum hcl_obj_type_t hcl_obj_type_t;
#define HCL_OBJ_HEADER \ #define HCL_OBJ_HEADER \
hcl_oow_t _flags; \ hcl_oow_t _flags; \
hcl_oow_t _size; \ hcl_oow_t _size
hcl_oop_t _class
struct hcl_obj_t struct hcl_obj_t
{ {
@ -819,6 +818,75 @@ struct hcl_heap_t
hcl_mmgr_t xmmgr; hcl_mmgr_t xmmgr;
}; };
typedef struct hcl_dbgi_t hcl_dbgi_t;
struct hcl_dbgi_t
{
hcl_oow_t _capa;
hcl_oow_t _len;
hcl_oow_t _last_file; /* offset to the last file element added */
hcl_oow_t _last_class; /* offset to the last class element added */
hcl_oow_t _last_text; /* offset to the last text element added */
hcl_oow_t _last_method;
/* actual information is recorded here */
};
enum hcl_dbgi_type_t
{
/* bit 8 to bit 15 */
HCL_DBGI_TYPE_CODE_FILE = 0,
HCL_DBGI_TYPE_CODE_CLASS = 1,
HCL_DBGI_TYPE_CODE_TEXT = 2,
/* TODO: interface? etc? */
HCL_DBGI_TYPE_CODE_METHOD = 3, /* method instruction location information */
/* low 8 bits */
HCL_DBGI_TYPE_FLAG_INVALID = (1 << 0)
};
typedef enum hcl_dbgi_type_t hcl_dbgi_type_t;
#define HCL_DBGI_MAKE_TYPE(code,flags) (((code) << 8) | (flags))
#define HCL_DBGI_GET_TYPE_CODE(type) ((type) >> 8)
#define HCL_DBGI_GET_TYPE_FLAGS(type) ((type) & 0xFF)
#define HCL_DBGI_GET_DATA(hcl, offset) ((hcl_uint8_t*)(hcl)->dbgi + (offset))
typedef struct hcl_dbgi_file_t hcl_dbgi_file_t;
struct hcl_dbgi_file_t
{
hcl_oow_t _type;
hcl_oow_t _len; /* length of this record including the header and the file path payload */
hcl_oow_t _next;
/* ... file path here ... */
};
typedef struct hcl_dbgi_class_t hcl_dbgi_class_t;
struct hcl_dbgi_class_t
{
hcl_oow_t _type;
hcl_oow_t _len; /* length of this record including the header and the class name payload */
hcl_oow_t _next; /* offset to a previous class */
hcl_oow_t _file;
hcl_oow_t _line;
/* ... class name here ... */
};
typedef struct hcl_dbgi_method_t hcl_dbgi_method_t;
struct hcl_dbgi_method_t
{
hcl_oow_t _type;
hcl_oow_t _len; /* length of this record including the header and the payload including method name and code line numbers */
hcl_oow_t _next;
hcl_oow_t _file;
hcl_oow_t _class;
hcl_oow_t start_line;
hcl_oow_t code_loc_start; /* start offset from the payload beginning within this record */
hcl_oow_t code_loc_len;
hcl_oow_t text_start;
hcl_oow_t text_len;
/* ... method name here ... */
/* ... code line numbers here ... */
};
/* ========================================================================= /* =========================================================================
* VM LOGGING * VM LOGGING
* ========================================================================= */ * ========================================================================= */
@ -1357,6 +1425,7 @@ struct hcl_t
/* ========================= */ /* ========================= */
hcl_heap_t* heap; hcl_heap_t* heap;
hcl_dbgi_t* dbgi;
/* ========================= */ /* ========================= */
hcl_oop_t _nil; /* pointer to the nil object */ hcl_oop_t _nil; /* pointer to the nil object */
@ -1488,6 +1557,9 @@ struct hcl_t
hcl_oop_oop_t arr; /* literal array - not part of object memory */ hcl_oop_oop_t arr; /* literal array - not part of object memory */
hcl_oow_t len; hcl_oow_t len;
} lit; } lit;
/* array that hold the location of the byte code emitted */
hcl_oow_t* locptr;
} code; } code;
/* == PRINTER == */ /* == PRINTER == */
@ -2004,6 +2076,24 @@ HCL_EXPORT void hcl_setsynerrufmt (
# define hcl_setsynerr(hcl,num,loc,tgt) hcl_setsynerrbfmt(hcl,num,loc,tgt,HCL_NULL) # define hcl_setsynerr(hcl,num,loc,tgt) hcl_setsynerrbfmt(hcl,num,loc,tgt,HCL_NULL)
#endif #endif
/* =========================================================================
* DEBUG SUPPORT
* ========================================================================= */
HCL_EXPORT int hcl_initdbgi (
hcl_t* hcl,
hcl_oow_t init_capa
);
/**
* The hcl_finidbgi() function deletes the debug information.
* It is called by hcl_close(). Unless you want the debug information to
* be deleted earlier, you need not call this function explicitly.
*/
HCL_EXPORT void hcl_finidbgi (
hcl_t* hcl
);
/* ========================================================================= /* =========================================================================
* TEMPORARY OOP MANAGEMENT FUNCTIONS * TEMPORARY OOP MANAGEMENT FUNCTIONS
* ========================================================================= */ * ========================================================================= */

13
lib/obj.c
View File

@ -139,7 +139,7 @@ static HCL_INLINE hcl_oop_t alloc_oop_array (hcl_t* hcl, int brand, hcl_oow_t si
hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, ngc, 0, 0); hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, ngc, 0, 0);
HCL_OBJ_SET_SIZE (hdr, size); HCL_OBJ_SET_SIZE (hdr, size);
HCL_OBJ_SET_CLASS (hdr, hcl->_nil); /*HCL_OBJ_SET_CLASS (hdr, hcl->_nil);*/
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand); HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
while (size > 0) hdr->slot[--size] = hcl->_nil; while (size > 0) hdr->slot[--size] = hcl->_nil;
@ -168,7 +168,7 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, int brand, hcl_oow_t size, con
hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, 0, 1, 0); hdr->_flags = HCL_OBJ_MAKE_FLAGS(HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 0, 0, 0, 1, 0);
HCL_OBJ_SET_SIZE (hdr, size); HCL_OBJ_SET_SIZE (hdr, size);
HCL_OBJ_SET_CLASS (hdr, hcl->_nil); /*HCL_OBJ_SET_CLASS (hdr, hcl->_nil);*/
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand); HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
for (i = 0; i < size; i++) hdr->slot[i] = hcl->_nil; for (i = 0; i < size; i++) hdr->slot[i] = hcl->_nil;
@ -215,7 +215,7 @@ static HCL_INLINE hcl_oop_t alloc_numeric_array (hcl_t* hcl, int brand, const vo
hdr->_flags = HCL_OBJ_MAKE_FLAGS(type, unit, extra, 0, 0, ngc, 0, 0); hdr->_flags = HCL_OBJ_MAKE_FLAGS(type, unit, extra, 0, 0, ngc, 0, 0);
hdr->_size = len; hdr->_size = len;
HCL_OBJ_SET_SIZE (hdr, len); HCL_OBJ_SET_SIZE (hdr, len);
HCL_OBJ_SET_CLASS (hdr, hcl->_nil); //HCL_OBJ_SET_CLASS (hdr, hcl->_nil);
HCL_OBJ_SET_FLAGS_BRAND (hdr, brand); HCL_OBJ_SET_FLAGS_BRAND (hdr, brand);
if (ptr) if (ptr)
@ -321,6 +321,13 @@ hcl_oop_t hcl_makebytearray (hcl_t* hcl, const hcl_oob_t* ptr, hcl_oow_t size)
return hcl_allocbyteobj(hcl, HCL_BRAND_BYTE_ARRAY, ptr, size); return hcl_allocbyteobj(hcl, HCL_BRAND_BYTE_ARRAY, ptr, size);
} }
hcl_oop_t hcl_makedlist (hcl_t* hcl)
{
//return hcl_allocoopobj(hcl, HCL_BRAND_DLIST);
hcl_seterrnum (hcl, HCL_ENOIMPL);
return HCL_NULL;
}
hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len, int ngc) hcl_oop_t hcl_makestring (hcl_t* hcl, const hcl_ooch_t* ptr, hcl_oow_t len, int ngc)
{ {
/*return hcl_alloccharobj(hcl, HCL_BRAND_STRING, ptr, len);*/ /*return hcl_alloccharobj(hcl, HCL_BRAND_STRING, ptr, len);*/

10
lib/read.c
View File

@ -780,7 +780,7 @@ static int get_sharp_token (hcl_t* hcl)
* #\UHHHH unicode character * #\UHHHH unicode character
* #\uHHHH unicode character * #\uHHHH unicode character
* #[ ] byte array * #[ ] byte array
* #{ } qlist * #( ) qlist
*/ */
switch (c) switch (c)
@ -1382,7 +1382,7 @@ static int end_include (hcl_t* hcl)
/* if it is an included file, close it and /* if it is an included file, close it and
* retry to read a character from an outer file */ * retry to read a character from an outer file */
x = hcl->c->reader (hcl, HCL_IO_CLOSE, hcl->c->curinp); x = hcl->c->reader(hcl, HCL_IO_CLOSE, hcl->c->curinp);
/* if closing has failed, still destroy the /* if closing has failed, still destroy the
* sio structure first as normal and return * sio structure first as normal and return
@ -1855,12 +1855,16 @@ static int read_object (hcl_t* hcl)
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DIC); LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_DIC);
goto start_list; goto start_list;
#if 0
case HCL_IOTOK_QLPAREN: /* #() */ case HCL_IOTOK_QLPAREN: /* #() */
#if 1
hcl_setsynerr (hcl, HCL_SYNERR_ILTOK, TOKEN_LOC(hcl), TOKEN_NAME(hcl));
return -1;
#else
flagv = 0; flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST); LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_QLIST);
goto start_list; goto start_list;
#endif #endif
case HCL_IOTOK_LPAREN: /* () */ case HCL_IOTOK_LPAREN: /* () */
flagv = 0; flagv = 0;
LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_XLIST); LIST_FLAG_SET_CONCODE (flagv, HCL_CONCODE_XLIST);