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

changing vm implementation a bit. this commit is buggy

Browse Source
This commit is contained in:
hyung-hwan
2020-10-04 18:21:05 +00:00
parent 5b7b2c0dea
commit 4d0f0e1f9e
8 changed files with 320 additions and 255 deletions
Download Patch File Download Diff File Expand all files Collapse all files

8
hcl/lib/comp.c
View File

@ -1062,11 +1062,7 @@ static int compile_lambda (hcl_t* hcl, hcl_oop_t src, int defun)
hcl->c->blk.depth++; hcl->c->blk.depth++;
if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, hcl->code.lit.len) <= -1) return -1; if (store_temporary_variable_count_for_block(hcl, hcl->c->tv.size, hcl->code.lit.len) <= -1) return -1;
/* use the accumulated number of temporaries so far when generating if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_BLOCK, nargs, ntmprs) <= -1) return -1;
* the make_block instruction. at context activation time, the actual
* count of temporaries for this block is derived by subtracting the
* count of temporaries in the home context */
if (emit_double_param_instruction(hcl, HCL_CODE_MAKE_BLOCK, nargs, hcl->c->tv.size/*ntmprs*/) <= -1) return -1;
HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */ HCL_ASSERT (hcl, hcl->code.bc.len < HCL_SMOOI_MAX); /* guaranteed in emit_byte_instruction() */
jump_inst_pos = hcl->code.bc.len; jump_inst_pos = hcl->code.bc.len;
@ -1557,7 +1553,6 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_oop_t obj)
static int emit_indexed_variable_access (hcl_t* hcl, hcl_oow_t index, hcl_oob_t baseinst1, hcl_oob_t baseinst2) static int emit_indexed_variable_access (hcl_t* hcl, hcl_oow_t index, hcl_oob_t baseinst1, hcl_oob_t baseinst2)
{ {
#if defined(HCL_USE_CTXTEMPVAR)
if (hcl->c->blk.depth >= 0) if (hcl->c->blk.depth >= 0)
{ {
hcl_oow_t i; hcl_oow_t i;
@ -1582,7 +1577,6 @@ static int emit_indexed_variable_access (hcl_t* hcl, hcl_oow_t index, hcl_oob_t
} }
} }
} }
#endif
/* TODO: top-level... verify this. this will vary depending on how i implement the top-level and global variables... */ /* TODO: top-level... verify this. this will vary depending on how i implement the top-level and global variables... */
if (emit_single_param_instruction (hcl, baseinst2, index) <= -1) return -1; if (emit_single_param_instruction (hcl, baseinst2, index) <= -1) return -1;

26
hcl/lib/decode.c
View File

@ -35,11 +35,13 @@
# define LOG_INST_1(hcl,fmt,a1) # define LOG_INST_1(hcl,fmt,a1)
# define LOG_INST_2(hcl,fmt,a1,a2) # define LOG_INST_2(hcl,fmt,a1,a2)
# define LOG_INST_3(hcl,fmt,a1,a2,a3) # define LOG_INST_3(hcl,fmt,a1,a2,a3)
# define LOG_INST_4(hcl,fmt,a1,a2,a3,a4)
#else #else
# define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer) # define LOG_INST_0(hcl,fmt) HCL_LOG1(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer)
# define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1) # define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1)
# define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2) # define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2)
# define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3) # define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3)
# define LOG_INST_4(hcl,fmt,a1,a2,a3,a4) HCL_LOG5(hcl, DECODE_LOG_MASK, " %06zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3, a4)
#endif #endif
#define FETCH_BYTE_CODE(hcl) (cdptr[ip++]) #define FETCH_BYTE_CODE(hcl) (cdptr[ip++])
@ -59,7 +61,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
{ {
hcl_oob_t bcode, * cdptr; hcl_oob_t bcode, * cdptr;
hcl_ooi_t ip = start, fetched_instruction_pointer; hcl_ooi_t ip = start, fetched_instruction_pointer;
hcl_oow_t b1, b2; hcl_oow_t b1, b2, b3, b4;
/* the instruction at the offset 'end' is not decoded. /* the instruction at the offset 'end' is not decoded.
* decoding offset range is from start to end - 1. */ * decoding offset range is from start to end - 1. */
@ -550,6 +552,23 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
LOG_INST_0 (hcl, "return_from_block"); LOG_INST_0 (hcl, "return_from_block");
break; break;
case HCL_CODE_MAKE_FUNCTION:
/* b1 - number of block arguments
* b2 - number of block temporaries
* b3 - base literal frame start
* b4 - base literal frame end */
FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2);
FETCH_PARAM_CODE_TO (hcl, b3);
FETCH_PARAM_CODE_TO (hcl, b4);
LOG_INST_4 (hcl, "make_function %zu %zu %zu %zu", b1, b2, b3, b4);
HCL_ASSERT (hcl, b1 >= 0);
HCL_ASSERT (hcl, b2 >= b1);
HCL_ASSERT (hcl, b4 >= b3);
break;
case HCL_CODE_MAKE_BLOCK: case HCL_CODE_MAKE_BLOCK:
/* b1 - number of block arguments /* b1 - number of block arguments
* b2 - number of block temporaries */ * b2 - number of block temporaries */
@ -562,10 +581,6 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
HCL_ASSERT (hcl, b2 >= b1); HCL_ASSERT (hcl, b2 >= b1);
break; break;
case HCL_CODE_SEND_BLOCK_COPY:
LOG_INST_0 (hcl, "send_block_copy");
break;
case HCL_CODE_NOOP: case HCL_CODE_NOOP:
/* do nothing */ /* do nothing */
LOG_INST_0 (hcl, "noop"); LOG_INST_0 (hcl, "noop");
@ -578,6 +593,7 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
} }
} }
// TODO: this needs changes... */
/* print literal frame contents */ /* print literal frame contents */
for (ip = 0; ip < hcl->code.lit.len; ip++) for (ip = 0; ip < hcl->code.lit.len; ip++)
{ {

2
hcl/lib/dic.c
View File

@ -363,7 +363,7 @@ hcl_oop_t hcl_makedic (hcl_t* hcl, hcl_oow_t inisize)
{ {
hcl_oop_dic_t obj; hcl_oop_dic_t obj;
obj = (hcl_oop_dic_t)hcl_allocoopobj (hcl, HCL_BRAND_DIC, 2); obj = (hcl_oop_dic_t)hcl_allocoopobj(hcl, HCL_BRAND_DIC, 2);
if (obj) if (obj)
{ {
hcl_oop_oop_t bucket; hcl_oop_oop_t bucket;

433
hcl/lib/exec.c
View File

@ -82,12 +82,14 @@ static HCL_INLINE const char* proc_state_to_string (int state)
{ \ { \
STORE_ACTIVE_IP (hcl); \ STORE_ACTIVE_IP (hcl); \
(hcl)->active_context = (v_ctx); \ (hcl)->active_context = (v_ctx); \
(hcl)->active_function = (hcl_oop_function_t)(hcl)->active_context->origin; \
(hcl)->active_code = HCL_FUNCTION_GET_CODE_BYTE((hcl)->active_function); \
LOAD_ACTIVE_IP (hcl); \ LOAD_ACTIVE_IP (hcl); \
(hcl)->processor->active->current_context = (hcl)->active_context; \ (hcl)->processor->active->current_context = (hcl)->active_context; \
} while (0) } while (0)
/*#define FETCH_BYTE_CODE(hcl) ((hcl)->code.bc.arr->slot[(hcl)->ip++])*/
#define FETCH_BYTE_CODE(hcl) ((hcl)->code.bc.arr->slot[(hcl)->ip++]) #define FETCH_BYTE_CODE(hcl) ((hcl)->active_code[(hcl)->ip++])
#define FETCH_BYTE_CODE_TO(hcl, v_oow) (v_oow = FETCH_BYTE_CODE(hcl)) #define FETCH_BYTE_CODE_TO(hcl, v_oow) (v_oow = FETCH_BYTE_CODE(hcl))
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2) #if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
# define FETCH_PARAM_CODE_TO(hcl, v_oow) \ # define FETCH_PARAM_CODE_TO(hcl, v_oow) \
@ -107,12 +109,14 @@ static HCL_INLINE const char* proc_state_to_string (int state)
# define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, LOG_MASK_INST, "%010zd " fmt "\n",fetched_instruction_pointer, a1) # define LOG_INST_1(hcl,fmt,a1) HCL_LOG2(hcl, LOG_MASK_INST, "%010zd " fmt "\n",fetched_instruction_pointer, a1)
# define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2) # define LOG_INST_2(hcl,fmt,a1,a2) HCL_LOG3(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2)
# define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3) # define LOG_INST_3(hcl,fmt,a1,a2,a3) HCL_LOG4(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3)
# define LOG_INST_4(hcl,fmt,a1,a2,a3,a4) HCL_LOG5(hcl, LOG_MASK_INST, "%010zd " fmt "\n", fetched_instruction_pointer, a1, a2, a3, a4)
#else #else
# define LOG_INST_0(hcl,fmt) # define LOG_INST_0(hcl,fmt)
# define LOG_INST_1(hcl,fmt,a1) # define LOG_INST_1(hcl,fmt,a1)
# define LOG_INST_2(hcl,fmt,a1,a2) # define LOG_INST_2(hcl,fmt,a1,a2)
# define LOG_INST_3(hcl,fmt,a1,a2,a3) # define LOG_INST_3(hcl,fmt,a1,a2,a3)
# define LOG_INST_3(hcl,fmt,a1,a2,a3,a4)
#endif #endif
static int vm_startup (hcl_t* hcl) static int vm_startup (hcl_t* hcl)
@ -164,6 +168,29 @@ static HCL_INLINE hcl_oop_t make_context (hcl_t* hcl, hcl_ooi_t ntmprs)
return hcl_allocoopobj(hcl, HCL_BRAND_CONTEXT, HCL_CONTEXT_NAMED_INSTVARS + (hcl_oow_t)ntmprs); return hcl_allocoopobj(hcl, HCL_BRAND_CONTEXT, HCL_CONTEXT_NAMED_INSTVARS + (hcl_oow_t)ntmprs);
} }
static HCL_INLINE hcl_oop_t make_function (hcl_t* hcl, hcl_oow_t lfsize, const hcl_oob_t* bptr, hcl_oow_t blen)
{
/* the literal frame is placed in the variable part.
* the byte code is placed in the trailer space */
return hcl_allocoopobjwithtrailer(hcl, HCL_BRAND_FUNCTION, HCL_FUNCTION_NAMED_INSTVARS + lfsize, bptr, blen);
}
static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func, hcl_ooi_t nargs, hcl_ooi_t ntmprs, hcl_oop_t homectx, const hcl_oop_t* lfptr, hcl_oow_t lfsize)
{
/* Although this function could be integrated into make_function(),
* this function has been separated from make_function() to make GC handling simpler */
hcl_oow_t i;
/* copy literal frames */
HCL_ASSERT (hcl, lfsize <= HCL_OBJ_GET_SIZE(func) - HCL_FUNCTION_NAMED_INSTVARS);
for (i = 0; i < lfsize; i++) func->literal_frame[i] = lfptr[i];
/* initialize other fields */
func->home = homectx;
func->nargs = HCL_SMOOI_TO_OOP(nargs);
func->ntmprs = HCL_SMOOI_TO_OOP(ntmprs);
}
static HCL_INLINE int prepare_to_alloc_pid (hcl_t* hcl) static HCL_INLINE int prepare_to_alloc_pid (hcl_t* hcl)
{ {
hcl_oow_t new_capa; hcl_oow_t new_capa;
@ -250,9 +277,9 @@ static hcl_oop_process_t make_process (hcl_t* hcl, hcl_oop_context_t c)
stksize = HCL_TYPE_MAX(hcl_oow_t) - HCL_PROCESS_NAMED_INSTVARS; stksize = HCL_TYPE_MAX(hcl_oow_t) - HCL_PROCESS_NAMED_INSTVARS;
hcl_pushtmp (hcl, (hcl_oop_t*)&c); hcl_pushtmp (hcl, (hcl_oop_t*)&c);
proc = (hcl_oop_process_t)hcl_allocoopobj (hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize); proc = (hcl_oop_process_t)hcl_allocoopobj(hcl, HCL_BRAND_PROCESS, HCL_PROCESS_NAMED_INSTVARS + stksize);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!proc) return HCL_NULL; if (HCL_UNLIKELY(!proc)) return HCL_NULL;
/* assign a process id to the process */ /* assign a process id to the process */
alloc_pid (hcl, proc); alloc_pid (hcl, proc);
@ -894,7 +921,7 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
/* the receiver must be a block context */ /* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_CONTEXT (hcl, rcv_blkctx)); HCL_ASSERT (hcl, HCL_IS_CONTEXT (hcl, rcv_blkctx));
if (rcv_blkctx->receiver_or_source != hcl->_nil) if (rcv_blkctx->receiver_or_base != hcl->_nil)
{ {
/* the 'source' field is not nil. /* the 'source' field is not nil.
* this block context has already been activated once. * this block context has already been activated once.
@ -908,25 +935,21 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
} }
HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS); HCL_ASSERT (hcl, HCL_OBJ_GET_SIZE(rcv_blkctx) == HCL_CONTEXT_NAMED_INSTVARS);
if (HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs) != nargs) if (HCL_OOP_TO_SMOOI(rcv_blkctx->nargs) != nargs)
{ {
HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
"Error - wrong number of arguments to a block context %O - expecting %zd, got %zd\n", "Error - wrong number of arguments to a block context %O - expecting %zd, got %zd\n",
rcv_blkctx, HCL_OOP_TO_SMOOI(rcv_blkctx->method_or_nargs), nargs); rcv_blkctx, HCL_OOP_TO_SMOOI(rcv_blkctx->nargs), nargs);
hcl_seterrnum (hcl, HCL_ECALLARG); hcl_seterrnum (hcl, HCL_ECALLARG);
return -1; return -1;
} }
/* the number of temporaries stored in the block context local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blkctx->ntmprs);
* accumulates the number of temporaries starting from the origin.
* simple calculation is needed to find the number of local temporaries */
local_ntmprs = HCL_OOP_TO_SMOOI(rcv_blkctx->ntmprs) -
HCL_OOP_TO_SMOOI(((hcl_oop_context_t)rcv_blkctx->home)->ntmprs);
HCL_ASSERT (hcl, local_ntmprs >= nargs); HCL_ASSERT (hcl, local_ntmprs >= nargs);
/* create a new block context to clone rcv_blkctx */ /* create a new block context to clone rcv_blkctx */
hcl_pushtmp (hcl, (hcl_oop_t*)&rcv_blkctx); hcl_pushtmp (hcl, (hcl_oop_t*)&rcv_blkctx);
blkctx = (hcl_oop_context_t) make_context(hcl, local_ntmprs); blkctx = (hcl_oop_context_t)make_context(hcl, local_ntmprs);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!blkctx) return -1; if (!blkctx) return -1;
@ -939,12 +962,90 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
#else #else
blkctx->ip = rcv_blkctx->ip; blkctx->ip = rcv_blkctx->ip;
blkctx->ntmprs = rcv_blkctx->ntmprs; blkctx->ntmprs = rcv_blkctx->ntmprs;
blkctx->method_or_nargs = rcv_blkctx->method_or_nargs; blkctx->nargs = rcv_blkctx->nargs;
blkctx->receiver_or_source = (hcl_oop_t)rcv_blkctx; blkctx->receiver_or_base = (hcl_oop_t)rcv_blkctx;
blkctx->home = rcv_blkctx->home; blkctx->home = rcv_blkctx->home;
blkctx->origin = rcv_blkctx->origin; blkctx->origin = rcv_blkctx->origin;
#endif #endif
/* TODO: check the stack size of a block context to see if it's large enough to hold arguments */
/* copy the arguments to the stack */
for (i = 0; i < nargs; i++)
{
blkctx->slot[i] = HCL_STACK_GETARG(hcl, nargs, i);
}
HCL_STACK_POPS (hcl, nargs + 1); /* pop arguments and receiver */
HCL_ASSERT (hcl, (rcv_blkctx == hcl->initial_context && blkctx->home == hcl->_nil) || blkctx->home != hcl->_nil);
blkctx->sp = HCL_SMOOI_TO_OOP(-1); /* not important at all */
blkctx->sender = hcl->active_context;
*pblkctx = blkctx;
return 0;
}
static HCL_INLINE int activate_context (hcl_t* hcl, hcl_ooi_t nargs)
{
int x;
hcl_oop_context_t rcv, blkctx;
rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_CONTEXT(hcl, rcv));
x = __activate_context(hcl, rcv, nargs, &blkctx);
if (HCL_UNLIKELY(x <= -1)) return -1;
SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx);
return 0;
}
/* ------------------------------------------------------------------------- */
static int __activate_function (hcl_t* hcl, hcl_oop_function_t rcv_func, hcl_ooi_t nargs, hcl_oop_context_t* pblkctx)
{
/* prepare a new block context for activation.
* the receiver must be a block context which becomes the base
* for a new block context. */
hcl_oop_context_t blkctx;
hcl_ooi_t local_ntmprs, i;
/*
* (defun sum (x)
* (if (< x 2) 1
* else (+ x (sum (- x 1)))))
* (printf ">>>> %d\n" (sum 10))
*/
/* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_FUNCTION(hcl, rcv_func));
if (HCL_OOP_TO_SMOOI(rcv_func->nargs) != nargs)
{
HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
"Error - wrong number of arguments to a function %O - expecting %zd, got %zd\n",
rcv_func, HCL_OOP_TO_SMOOI(rcv_func->nargs), nargs);
hcl_seterrnum (hcl, HCL_ECALLARG);
return -1;
}
local_ntmprs = HCL_OOP_TO_SMOOI(rcv_func->ntmprs);
HCL_ASSERT (hcl, local_ntmprs >= nargs);
/* create a new block context to clone rcv_func */
hcl_pushtmp (hcl, (hcl_oop_t*)&rcv_func);
blkctx = (hcl_oop_context_t)make_context(hcl, local_ntmprs);
hcl_poptmp (hcl);
if (!blkctx) return -1;
blkctx->ip = HCL_SMOOI_TO_OOP(0);
blkctx->ntmprs = rcv_func->ntmprs;
blkctx->nargs = rcv_func->nargs;
blkctx->receiver_or_base = (hcl_oop_t)rcv_func;
blkctx->home = rcv_func->home;
blkctx->origin = rcv_func;
/* TODO: check the stack size of a block context to see if it's large enough to hold arguments */ /* TODO: check the stack size of a block context to see if it's large enough to hold arguments */
/* copy the arguments to the stack */ /* copy the arguments to the stack */
for (i = 0; i < nargs; i++) for (i = 0; i < nargs; i++)
@ -962,16 +1063,16 @@ static int __activate_context (hcl_t* hcl, hcl_oop_context_t rcv_blkctx, hcl_ooi
return 0; return 0;
} }
static HCL_INLINE int activate_context (hcl_t* hcl, hcl_ooi_t nargs) static HCL_INLINE int activate_function (hcl_t* hcl, hcl_ooi_t nargs)
{ {
int x; int x;
hcl_oop_context_t rcv, blkctx; hcl_oop_context_t rcv, blkctx;
rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs); rcv = (hcl_oop_context_t)HCL_STACK_GETRCV(hcl, nargs);
HCL_ASSERT (hcl, HCL_IS_CONTEXT (hcl, rcv)); HCL_ASSERT (hcl, HCL_IS_FUNCTION(hcl, rcv));
x = __activate_context (hcl, rcv, nargs, &blkctx); x = __activate_function(hcl, rcv, nargs, &blkctx);
if (x <= -1) return -1; if (HCL_UNLIKELY(x <= -1)) return -1;
SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx); SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)blkctx);
return 0; return 0;
@ -1187,11 +1288,11 @@ static hcl_oop_process_t start_initial_process (hcl_t* hcl, hcl_oop_context_t ct
HCL_ASSERT (hcl, hcl->processor->tally == HCL_SMOOI_TO_OOP(0)); HCL_ASSERT (hcl, hcl->processor->tally == HCL_SMOOI_TO_OOP(0));
HCL_ASSERT (hcl, hcl->processor->active == hcl->nil_process); HCL_ASSERT (hcl, hcl->processor->active == hcl->nil_process);
proc = make_process (hcl, ctx); proc = make_process(hcl, ctx);
if (!proc) return HCL_NULL; if (HCL_UNLIKELY(!proc)) return HCL_NULL;
/* skip RUNNABLE and go to RUNNING */ /* skip RUNNABLE and go to RUNNING */
if (chain_into_processor (hcl, proc, PROC_STATE_RUNNING) <= -1) return HCL_NULL; if (chain_into_processor(hcl, proc, PROC_STATE_RUNNING) <= -1) return HCL_NULL;
hcl->processor->active = proc; hcl->processor->active = proc;
/* do something that resume_process() would do with less overhead */ /* do something that resume_process() would do with less overhead */
@ -1207,7 +1308,7 @@ static int start_initial_process_and_context (hcl_t* hcl, hcl_ooi_t initial_ip)
hcl_oop_context_t ctx; hcl_oop_context_t ctx;
hcl_oop_process_t proc; hcl_oop_process_t proc;
/* create a fake initial context. */ /* create a fake initial context over the initial function */
ctx = (hcl_oop_context_t)make_context(hcl, 0); /* no temporary variables */ ctx = (hcl_oop_context_t)make_context(hcl, 0); /* no temporary variables */
if (!ctx) return -1; if (!ctx) return -1;
@ -1218,15 +1319,14 @@ static int start_initial_process_and_context (hcl_t* hcl, hcl_ooi_t initial_ip)
hcl->ip = initial_ip; hcl->ip = initial_ip;
hcl->sp = -1; hcl->sp = -1;
ctx->ip = HCL_SMOOI_TO_OOP(0); /* point to the beginning */ ctx->ip = HCL_SMOOI_TO_OOP(initial_ip);
ctx->sp = HCL_SMOOI_TO_OOP(-1); /* pointer to -1 below the bottom */ ctx->sp = HCL_SMOOI_TO_OOP(-1); /* pointer to -1 below the bottom */
ctx->origin = ctx; /* point to self */ /*ctx->nargs = (hcl_oop_t)mth;*/ /* fake. help SWITCH_ACTIVE_CONTEXT() not fail. */
/*ctx->method_or_nargs = (hcl_oop_t)mth;*/ /* fake. help SWITCH_ACTIVE_CONTEXT() not fail. */ ctx->nargs = HCL_SMOOI_TO_OOP(0);
ctx->method_or_nargs = HCL_SMOOI_TO_OOP(0);
/* TODO: XXXXX */
ctx->ntmprs = HCL_SMOOI_TO_OOP(0); ctx->ntmprs = HCL_SMOOI_TO_OOP(0);
ctx->home = (hcl_oop_t)ctx; /* is this correct??? */ ctx->origin = hcl->initial_function;
/* END XXXXX */ ctx->home = hcl->initial_function->home; /* this should be nil */
HCL_ASSERT (hcl, ctx->home == hcl->_nil);
/* [NOTE] /* [NOTE]
* the receiver field and the sender field of ctx are nils. * the receiver field and the sender field of ctx are nils.
@ -1247,14 +1347,16 @@ static int start_initial_process_and_context (hcl_t* hcl, hcl_ooi_t initial_ip)
hcl->active_context = ctx; hcl->active_context = ctx;
hcl_pushtmp (hcl, (hcl_oop_t*)&ctx); hcl_pushtmp (hcl, (hcl_oop_t*)&ctx);
proc = start_initial_process (hcl, ctx); proc = start_initial_process(hcl, ctx);
hcl_poptmp (hcl); hcl_poptmp (hcl);
if (!proc) return -1; if (HCL_UNLIKELY(!proc)) return -1;
HCL_STACK_PUSH (hcl, (hcl_oop_t)ctx); HCL_STACK_PUSH (hcl, (hcl_oop_t)ctx);
STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */ STORE_ACTIVE_SP (hcl); /* hcl->active_context->sp = HCL_SMOOI_TO_OOP(hcl->sp) */
return activate_context (hcl, 0); HCL_ASSERT (hcl, proc == hcl->processor->active);
hcl->initial_context = proc->initial_context;
return activate_context(hcl, 0);
} }
/* ------------------------------------------------------------------------- */ /* ------------------------------------------------------------------------- */
@ -1425,8 +1527,8 @@ static int execute (hcl_t* hcl)
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
push_instvar: push_instvar:
LOG_INST_1 (hcl, "push_instvar %zu", b1); LOG_INST_1 (hcl, "push_instvar %zu", b1);
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->origin->receiver_or_source) == HCL_OBJ_TYPE_OOP); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->origin->receiver_or_base) == HCL_OBJ_TYPE_OOP);
HCL_STACK_PUSH (hcl, ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_source)->slot[b1]); HCL_STACK_PUSH (hcl, ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_base)->slot[b1]);
break; break;
/* ------------------------------------------------- */ /* ------------------------------------------------- */
@ -1445,8 +1547,8 @@ static int execute (hcl_t* hcl)
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
store_instvar: store_instvar:
LOG_INST_1 (hcl, "store_into_instvar %zu", b1); LOG_INST_1 (hcl, "store_into_instvar %zu", b1);
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver_or_source) == HCL_OBJ_TYPE_OOP); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver_or_base) == HCL_OBJ_TYPE_OOP);
((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_source)->slot[b1] = HCL_STACK_GETTOP(hcl); ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_base)->slot[b1] = HCL_STACK_GETTOP(hcl);
break; break;
/* ------------------------------------------------- */ /* ------------------------------------------------- */
@ -1464,8 +1566,8 @@ static int execute (hcl_t* hcl)
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
pop_into_instvar: pop_into_instvar:
LOG_INST_1 (hcl, "pop_into_instvar %zu", b1); LOG_INST_1 (hcl, "pop_into_instvar %zu", b1);
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver_or_source) == HCL_OBJ_TYPE_OOP); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(hcl->active_context->receiver_or_base) == HCL_OBJ_TYPE_OOP);
((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_source)->slot[b1] = HCL_STACK_GETTOP(hcl); ((hcl_oop_oop_t)hcl->active_context->origin->receiver_or_base)->slot[b1] = HCL_STACK_GETTOP(hcl);
HCL_STACK_POP (hcl); HCL_STACK_POP (hcl);
break; break;
#endif #endif
@ -1508,7 +1610,6 @@ static int execute (hcl_t* hcl)
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
handle_tempvar: handle_tempvar:
#if defined(HCL_USE_CTXTEMPVAR)
/* when CTXTEMPVAR inststructions are used, the above /* when CTXTEMPVAR inststructions are used, the above
* instructions are used only for temporary access * instructions are used only for temporary access
* outside a block. i can assume that the temporary * outside a block. i can assume that the temporary
@ -1517,48 +1618,6 @@ static int execute (hcl_t* hcl)
ctx = hcl->active_context->origin; ctx = hcl->active_context->origin;
bx = b1; bx = b1;
HCL_ASSERT (hcl, HCL_IS_CONTEXT(hcl, ctx)); HCL_ASSERT (hcl, HCL_IS_CONTEXT(hcl, ctx));
#else
/* otherwise, the index may point to a temporaries
* declared inside a block */
if (hcl->active_context->home != hcl->_nil)
{
/* this code assumes that the method context and
* the block context place some key fields in the
* same offset. such fields include 'home', 'ntmprs' */
hcl_oop_t home;
hcl_ooi_t home_ntmprs;
ctx = hcl->active_context;
home = ctx->home;
do
{
/* ntmprs contains the number of defined temporaries
* including those defined in the home context */
home_ntmprs = HCL_OOP_TO_SMOOI(((hcl_oop_context_t)home)->ntmprs);
if (b1 >= home_ntmprs) break;
ctx = (hcl_oop_context_t)home;
home = ((hcl_oop_context_t)home)->home;
if (home == hcl->_nil)
{
home_ntmprs = 0;
break;
}
}
while (1);
/* bx is the actual index within the actual context
* containing the temporary */
bx = b1 - home_ntmprs;
}
else
{
ctx = hcl->active_context;
bx = b1;
}
#endif
if ((bcode >> 4) & 1) if ((bcode >> 4) & 1)
{ {
@ -1612,7 +1671,7 @@ static int execute (hcl_t* hcl)
b1 = bcode & 0x7; /* low 3 bits */ b1 = bcode & 0x7; /* low 3 bits */
push_literal: push_literal:
LOG_INST_1 (hcl, "push_literal @%zu", b1); LOG_INST_1 (hcl, "push_literal @%zu", b1);
HCL_STACK_PUSH (hcl, hcl->code.lit.arr->slot[b1]); HCL_STACK_PUSH (hcl, hcl->active_function->literal_frame[b1]);
break; break;
/* ------------------------------------------------- */ /* ------------------------------------------------- */
@ -1639,7 +1698,7 @@ static int execute (hcl_t* hcl)
b1 = bcode & 0x3; /* low 2 bits */ b1 = bcode & 0x3; /* low 2 bits */
handle_object: handle_object:
ass = (hcl_oop_cons_t)hcl->code.lit.arr->slot[b1]; ass = (hcl_oop_cons_t)hcl->active_function->literal_frame[b1];
HCL_ASSERT (hcl, HCL_IS_CONS(hcl, ass)); HCL_ASSERT (hcl, HCL_IS_CONS(hcl, ass));
if ((bcode >> 3) & 1) if ((bcode >> 3) & 1)
@ -1759,6 +1818,11 @@ static int execute (hcl_t* hcl)
case HCL_BRAND_CONTEXT: case HCL_BRAND_CONTEXT:
if (activate_context(hcl, b1) <= -1) goto oops; if (activate_context(hcl, b1) <= -1) goto oops;
break; break;
case HCL_BRAND_FUNCTION:
if (activate_function(hcl, b1) <= -1) goto oops;
break;
case HCL_BRAND_PRIM: case HCL_BRAND_PRIM:
if (call_primitive(hcl, b1) <= -1) goto oops; if (call_primitive(hcl, b1) <= -1) goto oops;
break; break;
@ -1811,6 +1875,9 @@ static int execute (hcl_t* hcl)
for (i = 0; i < b1; i++) for (i = 0; i < b1; i++)
{ {
ctx = (hcl_oop_context_t)ctx->home; ctx = (hcl_oop_context_t)ctx->home;
/* the initial context has nil in the home field.
* the loop must not reach beyond the initial context */
HCL_ASSERT (hcl, ctx != hcl->_nil);
} }
if ((bcode >> 3) & 1) if ((bcode >> 3) & 1)
@ -1868,7 +1935,7 @@ static int execute (hcl_t* hcl)
FETCH_BYTE_CODE_TO (hcl, b2); FETCH_BYTE_CODE_TO (hcl, b2);
handle_objvar: handle_objvar:
t = (hcl_oop_oop_t)hcl->code.lit.arr->slot[b2]; t = (hcl_oop_oop_t)hcl->active_function->literal_frame[b2];
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(t) == HCL_OBJ_TYPE_OOP); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_TYPE(t) == HCL_OBJ_TYPE_OOP);
HCL_ASSERT (hcl, b1 < HCL_OBJ_GET_SIZE(t)); HCL_ASSERT (hcl, b1 < HCL_OBJ_GET_SIZE(t));
@ -1934,9 +2001,9 @@ static int execute (hcl_t* hcl)
#endif #endif
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
case HCL_CODE_PUSH_RECEIVER: case HCL_CODE_PUSH_RECEIVER: /* push self or super */
LOG_INST_0 (hcl, "push_receiver"); LOG_INST_0 (hcl, "push_receiver");
HCL_STACK_PUSH (hcl, hcl->active_context->origin->receiver_or_source); HCL_STACK_PUSH (hcl, hcl->active_context->origin->receiver_or_base);
break; break;
case HCL_CODE_PUSH_NIL: case HCL_CODE_PUSH_NIL:
@ -2128,7 +2195,7 @@ static int execute (hcl_t* hcl)
case HCL_CODE_RETURN_RECEIVER: case HCL_CODE_RETURN_RECEIVER:
LOG_INST_0 (hcl, "return_receiver"); LOG_INST_0 (hcl, "return_receiver");
return_value = hcl->active_context->origin->receiver_or_source; return_value = hcl->active_context->origin->receiver_or_base;
handle_return: handle_return:
if (hcl->active_context->origin == hcl->processor->active->initial_context->origin) if (hcl->active_context->origin == hcl->processor->active->initial_context->origin)
@ -2203,7 +2270,7 @@ static int execute (hcl_t* hcl)
/* /*
// HCL_ASSERT (hcl, HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context); // HCL_ASSERT (hcl, HCL_CLASSOF(hcl, hcl->active_context) == hcl->_method_context);
*/ */
HCL_ASSERT (hcl, hcl->active_context->receiver_or_source == hcl->_nil); HCL_ASSERT (hcl, hcl->active_context->receiver_or_base == hcl->_nil);
HCL_ASSERT (hcl, hcl->active_context == hcl->processor->active->initial_context); HCL_ASSERT (hcl, hcl->active_context == hcl->processor->active->initial_context);
HCL_ASSERT (hcl, hcl->active_context->origin == hcl->processor->active->initial_context->origin); HCL_ASSERT (hcl, hcl->active_context->origin == hcl->processor->active->initial_context->origin);
HCL_ASSERT (hcl, hcl->active_context->origin == hcl->active_context); HCL_ASSERT (hcl, hcl->active_context->origin == hcl->active_context);
@ -2263,6 +2330,52 @@ static int execute (hcl_t* hcl)
break; break;
case HCL_CODE_MAKE_FUNCTION:
{
hcl_oop_function_t func;
hcl_oow_t b3, b4, i, j;
hcl_oow_t joff;
/* b1 - number of block arguments
* b2 - number of block temporaries
* b3 - literal frame base
* b4 - literal frame size */
FETCH_PARAM_CODE_TO (hcl, b1);
FETCH_PARAM_CODE_TO (hcl, b2);
FETCH_PARAM_CODE_TO (hcl, b3);
FETCH_PARAM_CODE_TO (hcl, b4);
LOG_INST_4 (hcl, "make_function %zu %zu %zu %zu", b1, b2, b3, b4);
HCL_ASSERT (hcl, b1 >= 0);
HCL_ASSERT (hcl, b2 >= b1);
HCL_ASSERT (hcl, b3 >= 0);
/* the MAKE_FUNCTION instruction is followed by the long JUMP_FORWARD_X instruction.
* i can decode the instruction and get the size of instructions
* of the block context */
HCL_ASSERT (hcl, hcl->active_code[hcl->ip] == HCL_CODE_JUMP_FORWARD_X);
joff = hcl->active_code[hcl->ip + 1];
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
joff = (joff << 8) | hcl->active_code[hcl->ip + 2];
#endif
HCL_DEBUG1(hcl, "**** MAKE FUNCTION joff = %zu\n", joff);
/* copy the byte codes from the active context to the new context */
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
func = (hcl_oop_function_t)make_function(hcl, b4 - b3, &hcl->active_code[hcl->ip + 3], joff);
#else
func = (hcl_oop_function_t)make_function(hcl, b4 - b3, &hcl->active_code[hcl->ip + 2], joff);
#endif
if (HCL_UNLIKELY(!func)) goto oops;
fill_function_data (hcl, func, b1, b2, hcl->active_context, &hcl->active_function->literal_frame[b3], b4 - b3);
/* push the new function to the stack of the active context */
HCL_STACK_PUSH (hcl, (hcl_oop_t)func);
break;
}
case HCL_CODE_MAKE_BLOCK: case HCL_CODE_MAKE_BLOCK:
{ {
hcl_oop_context_t blkctx; hcl_oop_context_t blkctx;
@ -2277,38 +2390,13 @@ static int execute (hcl_t* hcl)
HCL_ASSERT (hcl, b1 >= 0); HCL_ASSERT (hcl, b1 >= 0);
HCL_ASSERT (hcl, b2 >= b1); HCL_ASSERT (hcl, b2 >= b1);
#if 0
if (hcl->option.trait & HCL_TRAIT_INTERACTIVE)
{
/* the MAKE_BLOCK instruction is followed by the long JUMP_FORWARD_X instruction.
* i can decode the instruction and get the size of instructions
* of the block context */
{
hcl_oow_t joff;
HCL_ASSERT (hcl, hcl->code.bc.arr->slot[hcl->ip] == HCL_CODE_JUMP_FORWARD_X);
joff = hcl->code.bc.arr->slot[hcl->ip + 1];
#if (HCL_HCL_CODE_LONG_PARAM_SIZE == 2)
joff = (joff << 8) | hcl->code.bc.arr->slot[hcl->ip + 2];
#endif
HCL_DEBUG1(hcl, "**** MAKE BLOCK joff = %zu\n", joff);
}
}
#endif
/* the block context object created here is used as a base /* the block context object created here is used as a base
* object for block context activation. activate_context() * object for block context activation. activate_context()
* clones a block context and activates the cloned context. * clones a block context and activates the cloned context.
* this base block context is created with no temporaries * this base block context is created with no temporaries
* for this reason */ * for this reason */
blkctx = (hcl_oop_context_t)make_context(hcl, 0); blkctx = (hcl_oop_context_t)make_context(hcl, 0);
if (!blkctx) goto oops; if (HCL_UNLIKELY(!blkctx)) goto oops;
/* the long forward jump instruction has the format of /* the long forward jump instruction has the format of
* 11000100 KKKKKKKK or 11000100 KKKKKKKK KKKKKKKK * 11000100 KKKKKKKK or 11000100 KKKKKKKK KKKKKKKK
@ -2318,17 +2406,15 @@ HCL_DEBUG1(hcl, "**** MAKE BLOCK joff = %zu\n", joff);
/* stack pointer below the bottom. this base block context /* stack pointer below the bottom. this base block context
* has an empty stack anyway. */ * has an empty stack anyway. */
blkctx->sp = HCL_SMOOI_TO_OOP(-1); blkctx->sp = HCL_SMOOI_TO_OOP(-1);
/* the number of arguments for a block context is local to the block */ /* the number of arguments */
blkctx->method_or_nargs = HCL_SMOOI_TO_OOP(b1); blkctx->nargs = HCL_SMOOI_TO_OOP(b1);
/* the number of temporaries here is an accumulated count including /* the number of temporaries including arguments */
* the number of temporaries of a home context */
blkctx->ntmprs = HCL_SMOOI_TO_OOP(b2); blkctx->ntmprs = HCL_SMOOI_TO_OOP(b2);
/* no source for a base block context. */
blkctx->receiver_or_base = hcl->_nil;
/* set the home context where it's defined */ /* set the home context where it's defined */
blkctx->home = (hcl_oop_t)hcl->active_context; blkctx->home = (hcl_oop_t)hcl->active_context;
/* no source for a base block context. */
blkctx->receiver_or_source = hcl->_nil;
blkctx->origin = hcl->active_context->origin; blkctx->origin = hcl->active_context->origin;
/* push the new block context to the stack of the active context */ /* push the new block context to the stack of the active context */
@ -2336,85 +2422,6 @@ HCL_DEBUG1(hcl, "**** MAKE BLOCK joff = %zu\n", joff);
break; break;
} }
case HCL_CODE_SEND_BLOCK_COPY:
{
hcl_ooi_t nargs, ntmprs;
hcl_oop_context_t rctx;
hcl_oop_context_t blkctx;
LOG_INST_0 (hcl, "send_block_copy");
/* it emulates thisContext blockCopy: nargs ofTmprCount: ntmprs */
HCL_ASSERT (hcl, hcl->sp >= 2);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(HCL_STACK_GETTOP(hcl)));
ntmprs = HCL_OOP_TO_SMOOI(HCL_STACK_GETTOP(hcl));
HCL_STACK_POP (hcl);
HCL_ASSERT (hcl, HCL_OOP_IS_SMOOI(HCL_STACK_GETTOP(hcl)));
nargs = HCL_OOP_TO_SMOOI(HCL_STACK_GETTOP(hcl));
HCL_STACK_POP (hcl);
HCL_ASSERT (hcl, nargs >= 0);
HCL_ASSERT (hcl, ntmprs >= nargs);
/* the block context object created here is used
* as a base object for block context activation.
* prim_block_value() clones a block
* context and activates the cloned context.
* this base block context is created with no
* stack for this reason. */
blkctx = (hcl_oop_context_t)make_context(hcl, 0);
if (!blkctx) goto oops;
/* get the receiver to the block copy message after block context instantiation
* not to get affected by potential GC */
rctx = (hcl_oop_context_t)HCL_STACK_GETTOP(hcl);
HCL_ASSERT (hcl, rctx == hcl->active_context);
/* [NOTE]
* blkctx->sender is left to nil. it is set to the
* active context before it gets activated. see
* prim_block_value().
*
* blkctx->home is set here to the active context.
* it's redundant to have them pushed to the stack
* though it is to emulate the message sending of
* blockCopy:withNtmprs:. HCL_CODE_MAKE_BLOCK has been
* added to replace HCL_CODE_SEND_BLOCK_COPY and pusing
* arguments to the stack.
*
* blkctx->origin is set here by copying the origin
* of the active context.
*/
/* the extended jump instruction has the format of
* 0000XXXX KKKKKKKK or 0000XXXX KKKKKKKK KKKKKKKK
* depending on HCL_HCL_CODE_LONG_PARAM_SIZE. change 'ip' to point to
* the instruction after the jump. */
blkctx->ip = HCL_SMOOI_TO_OOP(hcl->ip + HCL_HCL_CODE_LONG_PARAM_SIZE + 1);
blkctx->sp = HCL_SMOOI_TO_OOP(-1);
/* the number of arguments for a block context is local to the block */
blkctx->method_or_nargs = HCL_SMOOI_TO_OOP(nargs);
/* the number of temporaries here is an accumulated count including
* the number of temporaries of a home context */
blkctx->ntmprs = HCL_SMOOI_TO_OOP(ntmprs);
blkctx->home = (hcl_oop_t)rctx;
blkctx->receiver_or_source = hcl->_nil;
/* [NOTE]
* the origin of a method context is set to itself
* when it's created. so it's safe to simply copy
* the origin field this way.
*/
blkctx->origin = rctx->origin;
HCL_STACK_SETTOP (hcl, (hcl_oop_t)blkctx);
break;
}
case HCL_CODE_NOOP: case HCL_CODE_NOOP:
/* do nothing */ /* do nothing */
LOG_INST_0 (hcl, "noop"); LOG_INST_0 (hcl, "noop");
@ -2465,12 +2472,12 @@ hcl_oop_t hcl_executefromip (hcl_t* hcl, hcl_oow_t initial_ip)
hcl->last_retv = hcl->_nil; hcl->last_retv = hcl->_nil;
if (start_initial_process_and_context(hcl, initial_ip) <= -1) return HCL_NULL; n = start_initial_process_and_context(hcl, initial_ip);
hcl->initial_context = hcl->processor->active->initial_context; if (n >= 0)
{
n = execute (hcl); n = execute(hcl);
HCL_INFO1 (hcl, "RETURNED VALUE - %O\n", hcl->last_retv);
HCL_INFO1 (hcl, "RETURNED VALUE - %O\n", hcl->last_retv); }
/* TODO: reset processor fields. set processor->tally to zero. processor->active to nil_process... */ /* TODO: reset processor fields. set processor->tally to zero. processor->active to nil_process... */
hcl->initial_context = HCL_NULL; hcl->initial_context = HCL_NULL;
@ -2482,6 +2489,18 @@ hcl_oop_t hcl_executefromip (hcl_t* hcl, hcl_oow_t initial_ip)
hcl_oop_t hcl_execute (hcl_t* hcl) hcl_oop_t hcl_execute (hcl_t* hcl)
{ {
//////////////////////////////////////////////////////////////////////////////////////////////
hcl_oop_function_t func;
func = (hcl_oop_function_t)make_function(hcl, hcl->code.lit.len, hcl->code.bc.arr->slot, hcl->code.bc.len);
if (HCL_UNLIKELY(!func)) return HCL_NULL;
/* pass nil for the home context of the initial function */
fill_function_data (hcl, func, 0, 0, hcl->_nil, hcl->code.lit.arr->slot, hcl->code.lit.len);
hcl->initial_function = func;
//////////////////////////////////////////////////////////////////////////////////////////////
return hcl_executefromip (hcl, 0); return hcl_executefromip (hcl, 0);
} }

22
hcl/lib/gc.c
View File

@ -116,7 +116,6 @@ static void compact_symbol_table (hcl_t* hcl, hcl_oop_t _nil)
hcl->symtab->tally = HCL_SMOOI_TO_OOP(tally); hcl->symtab->tally = HCL_SMOOI_TO_OOP(tally);
} }
static HCL_INLINE hcl_oow_t get_payload_bytes (hcl_t* hcl, hcl_oop_t oop) static HCL_INLINE hcl_oow_t get_payload_bytes (hcl_t* hcl, hcl_oop_t oop)
{ {
hcl_oow_t nbytes_aligned; hcl_oow_t nbytes_aligned;
@ -142,15 +141,14 @@ static HCL_INLINE hcl_oow_t get_payload_bytes (hcl_t* hcl, hcl_oop_t oop)
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_UNIT(oop) == HCL_SIZEOF(hcl_oow_t)); HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_UNIT(oop) == HCL_SIZEOF(hcl_oow_t));
HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_EXTRA(oop) == 0); /* no 'extra' for an OOP object */ HCL_ASSERT (hcl, HCL_OBJ_GET_FLAGS_EXTRA(oop) == 0); /* no 'extra' for an OOP object */
nbytes = HCL_OBJ_BYTESOF(oop) + HCL_SIZEOF(hcl_oow_t) + \ nbytes = HCL_OBJ_BYTESOF(oop) + HCL_SIZEOF(hcl_oow_t) + HCL_OBJ_GET_TRAILER_SIZE(oop);
(hcl_oow_t)((hcl_oop_oop_t)oop)->slot[HCL_OBJ_GET_SIZE(oop)]; nbytes_aligned = HCL_ALIGN(nbytes, HCL_SIZEOF(hcl_oop_t));
nbytes_aligned = HCL_ALIGN (nbytes, HCL_SIZEOF(hcl_oop_t));
} }
else else
{ {
#endif #endif
/* calculate the payload size in bytes */ /* calculate the payload size in bytes */
nbytes_aligned = HCL_ALIGN (HCL_OBJ_BYTESOF(oop), HCL_SIZEOF(hcl_oop_t)); nbytes_aligned = HCL_ALIGN(HCL_OBJ_BYTESOF(oop), HCL_SIZEOF(hcl_oop_t));
#if defined(HCL_USE_OBJECT_TRAILER) #if defined(HCL_USE_OBJECT_TRAILER)
} }
#endif #endif
@ -180,10 +178,10 @@ hcl_oop_t hcl_moveoop (hcl_t* hcl, hcl_oop_t oop)
hcl_oow_t nbytes_aligned; hcl_oow_t nbytes_aligned;
hcl_oop_t tmp; hcl_oop_t tmp;
nbytes_aligned = get_payload_bytes (hcl, oop); nbytes_aligned = get_payload_bytes(hcl, oop);
/* allocate space in the new heap */ /* allocate space in the new heap */
tmp = (hcl_oop_t)hcl_allocheapmem (hcl, hcl->newheap, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned); tmp = (hcl_oop_t)hcl_allocheapmem(hcl, hcl->newheap, HCL_SIZEOF(hcl_obj_t) + nbytes_aligned);
/* allocation here must not fail because /* allocation here must not fail because
* i'm allocating the new space in a new heap for * i'm allocating the new space in a new heap for
@ -326,6 +324,7 @@ void hcl_gc (hcl_t* hcl)
hcl->processor = (hcl_oop_process_scheduler_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->processor); hcl->processor = (hcl_oop_process_scheduler_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->processor);
hcl->nil_process = (hcl_oop_process_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->nil_process); hcl->nil_process = (hcl_oop_process_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->nil_process);
for (i = 0; i < hcl->code.lit.len; i++) for (i = 0; i < hcl->code.lit.len; i++)
{ {
/* the literal array ia a NGC object. but the literal objects /* the literal array ia a NGC object. but the literal objects
@ -334,7 +333,7 @@ void hcl_gc (hcl_t* hcl)
hcl_moveoop(hcl, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i]); hcl_moveoop(hcl, ((hcl_oop_oop_t)hcl->code.lit.arr)->slot[i]);
} }
hcl->p.e = hcl_moveoop (hcl, hcl->p.e); hcl->p.e = hcl_moveoop(hcl, hcl->p.e);
for (i = 0; i < hcl->sem_list_count; i++) for (i = 0; i < hcl->sem_list_count; i++)
{ {
@ -355,6 +354,8 @@ void hcl_gc (hcl_t* hcl)
hcl->initial_context = (hcl_oop_context_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->initial_context); hcl->initial_context = (hcl_oop_context_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->initial_context);
if (hcl->active_context) if (hcl->active_context)
hcl->active_context = (hcl_oop_context_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->active_context); hcl->active_context = (hcl_oop_context_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->active_context);
if (hcl->initial_function)
hcl->initial_function = (hcl_oop_function_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->initial_function);
if (hcl->last_retv) hcl->last_retv = hcl_moveoop(hcl, hcl->last_retv); if (hcl->last_retv) hcl->last_retv = hcl_moveoop(hcl, hcl->last_retv);
@ -374,7 +375,7 @@ void hcl_gc (hcl_t* hcl)
compact_symbol_table (hcl, old_nil); compact_symbol_table (hcl, old_nil);
/* move the symbol table itself */ /* move the symbol table itself */
hcl->symtab = (hcl_oop_dic_t)hcl_moveoop (hcl, (hcl_oop_t)hcl->symtab); hcl->symtab = (hcl_oop_dic_t)hcl_moveoop(hcl, (hcl_oop_t)hcl->symtab);
/* scan the new heap again from the end position of /* scan the new heap again from the end position of
* the previous scan to move referenced objects by * the previous scan to move referenced objects by
@ -391,7 +392,6 @@ void hcl_gc (hcl_t* hcl)
hcl->curheap = hcl->newheap; hcl->curheap = hcl->newheap;
hcl->newheap = tmp; hcl->newheap = tmp;
/* /*
if (hcl->symtab && HCL_LOG_ENABLED(hcl, HCL_LOG_GC | HCL_LOG_DEBUG)) if (hcl->symtab && HCL_LOG_ENABLED(hcl, HCL_LOG_GC | HCL_LOG_DEBUG))
{ {
@ -410,6 +410,8 @@ void hcl_gc (hcl_t* hcl)
} }
*/ */
if (hcl->active_function) hcl->active_code = HCL_FUNCTION_GET_CODE_BYTE(hcl->active_function); /* update hcl->active_code */
/* TODO: include some gc statstics like number of live objects, gc performance, etc */ /* TODO: include some gc statstics like number of live objects, gc performance, etc */
HCL_LOG4 (hcl, HCL_LOG_GC | HCL_LOG_INFO, HCL_LOG4 (hcl, HCL_LOG_GC | HCL_LOG_INFO,
"Finished GC curheap base %p ptr %p newheap base %p ptr %p\n", "Finished GC curheap base %p ptr %p newheap base %p ptr %p\n",

14
hcl/lib/hcl-prv.h
View File

@ -37,14 +37,6 @@
* while hcl has not been fully initialized when this is defined*/ * while hcl has not been fully initialized when this is defined*/
#define HCL_SUPPORT_GC_DURING_IGNITION #define HCL_SUPPORT_GC_DURING_IGNITION
/* define this to generate XXXX_CTXTEMVAR instructions */
#define HCL_USE_CTXTEMPVAR
/* define this to use the MAKE_BLOCK instruction instead of
* PUSH_CONTEXT, PUSH_INTLIT, PUSH_INTLIT, SEND_BLOCK_COPY */
#define HCL_USE_MAKE_BLOCK
/* define this to enable karatsuba multiplication in bigint */ /* define this to enable karatsuba multiplication in bigint */
#define HCL_ENABLE_KARATSUBA #define HCL_ENABLE_KARATSUBA
#define HCL_KARATSUBA_CUTOFF 32 #define HCL_KARATSUBA_CUTOFF 32
@ -642,9 +634,10 @@ enum hcl_bcode_t
HCL_CODE_RETURN_STACKTOP = 0xF9, /* ^something */ HCL_CODE_RETURN_STACKTOP = 0xF9, /* ^something */
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 */
/* UNUSED 252 */
HCL_CODE_MAKE_FUNCTION = 0xFC, /* 252 */
HCL_CODE_MAKE_BLOCK = 0xFD, /* 253 */ HCL_CODE_MAKE_BLOCK = 0xFD, /* 253 */
HCL_CODE_SEND_BLOCK_COPY = 0xFE, /* 254 */ /* UNUSED 254 */
HCL_CODE_NOOP = 0xFF /* 255 */ HCL_CODE_NOOP = 0xFF /* 255 */
}; };
@ -725,6 +718,7 @@ hcl_oop_t hcl_allocoopobj (
#if defined(HCL_USE_OBJECT_TRAILER) #if defined(HCL_USE_OBJECT_TRAILER)
hcl_oop_t hcl_allocoopobjwithtrailer ( hcl_oop_t hcl_allocoopobjwithtrailer (
hcl_t* hcl, hcl_t* hcl,
int brand,
hcl_oow_t size, hcl_oow_t size,
const hcl_oob_t* tptr, const hcl_oob_t* tptr,
hcl_oow_t tlen hcl_oow_t tlen

63
hcl/lib/hcl.h
View File

@ -478,6 +478,10 @@ struct hcl_trailer_t
hcl_oob_t slot[1]; hcl_oob_t slot[1];
}; };
#define HCL_OBJ_GET_TRAILER_BYTE(oop) ((hcl_oob_t*)&((hcl_oop_oop_t)oop)->slot[HCL_OBJ_GET_SIZE(oop) + 1])
#define HCL_OBJ_GET_TRAILER_SIZE(oop) ((hcl_oow_t)((hcl_oop_oop_t)oop)->slot[HCL_OBJ_GET_SIZE(oop)])
#define HCL_CONS_NAMED_INSTVARS 2 #define HCL_CONS_NAMED_INSTVARS 2
typedef struct hcl_cons_t hcl_cons_t; typedef struct hcl_cons_t hcl_cons_t;
typedef struct hcl_cons_t* hcl_oop_cons_t; typedef struct hcl_cons_t* hcl_oop_cons_t;
@ -508,6 +512,32 @@ struct hcl_fpdec_t
hcl_oop_t scale; /* smooi, positive */ hcl_oop_t scale; /* smooi, positive */
}; };
#define HCL_FUNCTION_NAMED_INSTVARS 3 /* this excludes literal frames and byte codes */
typedef struct hcl_function_t hcl_function_t;
typedef struct hcl_function_t* hcl_oop_function_t;
struct hcl_function_t
{
HCL_OBJ_HEADER;
hcl_oop_t ntmprs; /* smooi */
hcl_oop_t nargs; /* smooi */
hcl_oop_t home; /* home function. nil for the initial function */
/* == variable indexed part == */
hcl_oop_t literal_frame[1]; /* it stores literals. it may not exist */
/* after the literal frame comes the actual byte code */
};
/* the first byte after the main payload is the trailer size
* the code bytes are placed after the trailer size.
*
* code bytes -> ((hcl_oob_t*)&((hcl_oop_oop_t)m)->slot[HCL_OBJ_GET_SIZE(m) + 1]) or
* ((hcl_oob_t*)&((hcl_oop_function_t)m)->literal_frame[HCL_OBJ_GET_SIZE(m) + 1 - HCL_METHOD_NAMED_INSTVARS])
* size -> ((hcl_oow_t)((hcl_oop_oop_t)m)->slot[HCL_OBJ_GET_SIZE(m)])*/
#define HCL_FUNCTION_GET_CODE_BYTE(m) HCL_OBJ_GET_TRAILER_BYTE(m)
#define HCL_FUNCTION_GET_CODE_SIZE(m) HCL_OBJ_GET_TRAILER_SIZE(m)
#define HCL_CONTEXT_NAMED_INSTVARS 8 #define HCL_CONTEXT_NAMED_INSTVARS 8
typedef struct hcl_context_t hcl_context_t; typedef struct hcl_context_t hcl_context_t;
typedef struct hcl_context_t* hcl_oop_context_t; typedef struct hcl_context_t* hcl_oop_context_t;
@ -530,34 +560,38 @@ struct hcl_context_t
* of the active process before it gets activated. */ * of the active process before it gets activated. */
hcl_oop_t sp; hcl_oop_t sp;
/* SmallInteger. Number of temporaries. /* SmallInteger. Number of temporaries. Includes arguments as well */
* For a block context, it's inclusive of the temporaries
* defined its 'home'. */
hcl_oop_t ntmprs; hcl_oop_t ntmprs;
/* CompiledMethod for a method context, /* SmallInteger. Number of arguments */
* SmallInteger for a block context */ hcl_oop_t nargs;
hcl_oop_t method_or_nargs;
/* it points to the receiver of the message for a method context. /* it points to the receiver of the message for a method context.
* a base block context(created but not yet activated) has nil in this * a base block context(created but not yet activated) has nil in this
* field. if a block context is activated by 'value', it points * field. if a block context is activated by 'value', it points
* to the block context object used as a base for shallow-copy. */ * to the block context object used as a base for shallow-copy. */
hcl_oop_t receiver_or_source; hcl_oop_t receiver_or_base; /* when used as a base, it's either a context or a function */
/* it is set to nil for a method context. /* it is set to nil for a method context.
* for a block context, it points to the active context at the * for a block context, it points to the active context at the
* moment the block context was created. that is, it points to * moment the block context was created. that is, it points to
* a method context where the base block has been defined. * a method context where the base block has been defined.
* an activated block context copies this field from the source. */ * an activated block context copies this field from the base block context. */
hcl_oop_t home; hcl_oop_t home;
/* when a method context is created, it is set to itself. no change is /* it points to the method context created of the method defining the code
* made when the method context is activated. when a block context is * of this context. a method context points to itself. a block context
* points to the method context where it is created. another block context
* created within the block context also points to the same method context.
* ctx->origin: method context
* ctx->origin->receiver_or_base: actual function containing byte codes pertaining to ctx.
*
* when a method context is created, it is set to itself. no change is
* made when the method context is activated. when a base block context is
* created (when MAKE_BLOCK or BLOCK_COPY is executed), it is set to the * created (when MAKE_BLOCK or BLOCK_COPY is executed), it is set to the
* origin of the active context. when the block context is shallow-copied * origin of the active context. when the base block context is shallow-copied
* for activation (when it is sent 'value'), it is set to the origin of * for activation (when it is sent 'value'), it is set to the origin of
* the source block context. */ * the base block context. */
hcl_oop_context_t origin; hcl_oop_context_t origin;
/* variable indexed part */ /* variable indexed part */
@ -1197,8 +1231,11 @@ struct hcl_t
int tagged_brands[16]; int tagged_brands[16];
/* == EXECUTION REGISTERS == */ /* == EXECUTION REGISTERS == */
hcl_oop_function_t initial_function;
hcl_oop_context_t initial_context; /* fake initial context */ hcl_oop_context_t initial_context; /* fake initial context */
hcl_oop_context_t active_context; hcl_oop_context_t active_context;
hcl_oop_function_t active_function;
hcl_oob_t* active_code;
hcl_ooi_t sp; hcl_ooi_t sp;
hcl_ooi_t ip; hcl_ooi_t ip;
int proc_switched; /* TODO: this is temporary. implement something else to skip immediate context switching */ int proc_switched; /* TODO: this is temporary. implement something else to skip immediate context switching */
@ -1346,6 +1383,7 @@ enum hcl_brand_t
HCL_BRAND_CFRAME,/* compiler frame */ HCL_BRAND_CFRAME,/* compiler frame */
HCL_BRAND_PRIM, HCL_BRAND_PRIM,
HCL_BRAND_FUNCTION,
HCL_BRAND_CONTEXT, HCL_BRAND_CONTEXT,
HCL_BRAND_PROCESS, HCL_BRAND_PROCESS,
HCL_BRAND_PROCESS_SCHEDULER, HCL_BRAND_PROCESS_SCHEDULER,
@ -1389,6 +1427,7 @@ typedef enum hcl_concode_t hcl_concode_t;
#define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL) #define HCL_IS_SYMBOL(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL)
#define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY) #define HCL_IS_SYMBOL_ARRAY(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_SYMBOL_ARRAY)
#define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT) #define HCL_IS_CONTEXT(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONTEXT)
#define HCL_IS_FUNCTION(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_FUNCTION)
#define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS) #define HCL_IS_PROCESS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_PROCESS)
#define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS) #define HCL_IS_CONS(hcl,v) (HCL_OOP_IS_POINTER(v) && HCL_OBJ_GET_FLAGS_BRAND(v) == HCL_BRAND_CONS)
#define HCL_IS_CONS_CONCODED(hcl,v,concode) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == (concode)) #define HCL_IS_CONS_CONCODED(hcl,v,concode) (HCL_IS_CONS(hcl,v) && HCL_OBJ_GET_FLAGS_SYNCODE(v) == (concode))

7
hcl/lib/obj.c
View File

@ -89,11 +89,11 @@ static HCL_INLINE hcl_oop_t alloc_oop_array (hcl_t* hcl, int brand, hcl_oow_t si
hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size) hcl_oop_t hcl_allocoopobj (hcl_t* hcl, int brand, hcl_oow_t size)
{ {
return alloc_oop_array (hcl, brand, size, 0); return alloc_oop_array(hcl, brand, size, 0);
} }
#if defined(HCL_USE_OBJECT_TRAILER) #if defined(HCL_USE_OBJECT_TRAILER)
hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_t* bptr, hcl_oow_t blen) hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, int brand, hcl_oow_t size, const hcl_oob_t* bptr, hcl_oow_t blen)
{ {
hcl_oop_oop_t hdr; hcl_oop_oop_t hdr;
hcl_oow_t nbytes, nbytes_aligned; hcl_oow_t nbytes, nbytes_aligned;
@ -109,6 +109,7 @@ hcl_oop_t hcl_allocoopobjwithtrailer (hcl_t* hcl, hcl_oow_t size, const hcl_oob_
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);
for (i = 0; i < size; i++) hdr->slot[i] = hcl->_nil; for (i = 0; i < size; i++) hdr->slot[i] = hcl->_nil;
@ -333,7 +334,7 @@ hcl_oop_t hcl_remakengcbytearray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)
hcl_oop_t hcl_makengcarray (hcl_t* hcl, hcl_oow_t len) hcl_oop_t hcl_makengcarray (hcl_t* hcl, hcl_oow_t len)
{ {
return alloc_numeric_array (hcl, HCL_BRAND_ARRAY, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1); return alloc_numeric_array(hcl, HCL_BRAND_ARRAY, HCL_NULL, len, HCL_OBJ_TYPE_OOP, HCL_SIZEOF(hcl_oop_t), 0, 1);
} }
hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize) hcl_oop_t hcl_remakengcarray (hcl_t* hcl, hcl_oop_t obj, hcl_oow_t newsize)