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

some more code to support multiple return values via return variables

Browse Source
This commit is contained in:
hyung-hwan
2021-05-13 14:43:40 +00:00
parent a67da34260
commit 32405a46eb
5 changed files with 75 additions and 28 deletions
Download Patch File Download Diff File Expand all files Collapse all files

30
hcl/lib/comp.c
View File

@ -3618,11 +3618,13 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
hcl_cframe_t* cf; hcl_cframe_t* cf;
hcl_oow_t block_code_size, lfsize; hcl_oow_t block_code_size, lfsize;
hcl_ooi_t jip; hcl_ooi_t jip;
hcl_fnblk_info_t* fbi;
cf = GET_TOP_CFRAME(hcl); cf = GET_TOP_CFRAME(hcl);
HCL_ASSERT (hcl, cf->opcode == COP_EMIT_LAMBDA); HCL_ASSERT (hcl, cf->opcode == COP_EMIT_LAMBDA);
HCL_ASSERT (hcl, cf->operand != HCL_NULL); HCL_ASSERT (hcl, cf->operand != HCL_NULL);
fbi = &hcl->c->fnblk.info[hcl->c->fnblk.depth];
jip = cf->u.lambda.jump_inst_pos; jip = cf->u.lambda.jump_inst_pos;
if (hcl->option.trait & HCL_TRAIT_INTERACTIVE) if (hcl->option.trait & HCL_TRAIT_INTERACTIVE)
@ -3631,16 +3633,30 @@ static HCL_INLINE int emit_lambda (hcl_t* hcl)
/* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */ /* HCL_CODE_LONG_PARAM_SIZE + 1 => size of the long JUMP_FORWARD instruction */
block_code_size = hcl->code.bc.len - jip - (HCL_CODE_LONG_PARAM_SIZE + 1); block_code_size = hcl->code.bc.len - jip - (HCL_CODE_LONG_PARAM_SIZE + 1);
if (block_code_size == 0) if (fbi->tmpr_nrvars > 0)
{ {
/* no body in lambda - (lambda (a b c)) */ /* this function block defines one or more return variables */
/* TODO: is this correct??? */ if (block_code_size > 0)
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1; {
if (emit_byte_instruction(hcl, HCL_CODE_POP_STACKTOP, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1;
block_code_size++;
}
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_RETURN_R, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1;
block_code_size++; block_code_size++;
} }
else
{
if (block_code_size == 0)
{
/* no body in lambda - (lambda (a b c)) */
/* TODO: is this correct??? */
if (emit_byte_instruction(hcl, HCL_CODE_PUSH_NIL, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1;
block_code_size++;
}
if (emit_byte_instruction(hcl, HCL_CODE_RETURN_FROM_BLOCK, HCL_CNODE_GET_LOC(cf->operand)) <= -1) return -1; if (emit_byte_instruction(hcl, HCL_CODE_RETURN_FROM_BLOCK, HCL_CNODE_GET_LOC(cf->operand)) <= -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)
{ {

4
hcl/lib/decode.c
View File

@ -335,6 +335,10 @@ int hcl_decode (hcl_t* hcl, hcl_oow_t start, hcl_oow_t end)
break; break;
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
case HCL_CODE_PUSH_RETURN_R:
LOG_INST_0 (hcl, "push_return_r");
break;
case HCL_CODE_CALL_R: case HCL_CODE_CALL_R:
FETCH_PARAM_CODE_TO (hcl, b1); /* nargs */ FETCH_PARAM_CODE_TO (hcl, b1); /* nargs */
FETCH_PARAM_CODE_TO (hcl, b2); /* nrvars */ FETCH_PARAM_CODE_TO (hcl, b2); /* nrvars */

48
hcl/lib/exec.c
View File

@ -363,7 +363,6 @@ static HCL_INLINE void fill_function_data (hcl_t* hcl, hcl_oop_function_t func,
/* initialize other fields */ /* initialize other fields */
func->home = homectx; func->home = homectx;
func->flags = HCL_SMOOI_TO_OOP(0);
func->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask); func->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask);
} }
@ -380,7 +379,6 @@ static HCL_INLINE void fill_block_data (hcl_t* hcl, hcl_oop_block_t blk, hcl_ooi
blk->home = homectx; blk->home = homectx;
blk->ip = HCL_SMOOI_TO_OOP(ip); blk->ip = HCL_SMOOI_TO_OOP(ip);
blk->flags = HCL_SMOOI_TO_OOP(0);
blk->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask); blk->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask);
} }
@ -1819,7 +1817,6 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t rcv_blk, hcl_ooi_t n
/* the receiver must be a block context */ /* the receiver must be a block context */
HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, rcv_blk)); HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, rcv_blk));
flags = HCL_OOP_TO_SMOOI(rcv_blk->flags);
tmpr_mask = HCL_OOP_TO_SMOOI(rcv_blk->tmpr_mask); tmpr_mask = HCL_OOP_TO_SMOOI(rcv_blk->tmpr_mask);
fblk_nrvars = GET_BLKTMPR_MASK_NRVARS(tmpr_mask); fblk_nrvars = GET_BLKTMPR_MASK_NRVARS(tmpr_mask);
@ -1837,12 +1834,12 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t rcv_blk, hcl_ooi_t n
return -1; return -1;
} }
if (fblk_nrvars != req_nrvars) if (req_nrvars > fblk_nrvars)
{ {
HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, HCL_LOG3 (hcl, HCL_LOG_IC | HCL_LOG_ERROR,
"Error - wrong number of returns specified of a block %O - expected %zd, requested %zd\n", "Error - wrong number of returns specified of a block %O - max expected %zd, requested %zd\n",
rcv_blk, fblk_nrvars, req_nrvars); rcv_blk, fblk_nrvars, req_nrvars);
hcl_seterrbfmt (hcl, HCL_ECALLRET, "wrong number of returns requested of function block - %zd expected, %zd requested", fblk_nrvars, req_nrvars); hcl_seterrbfmt (hcl, HCL_ECALLRET, "wrong number of returns requested of function block - %zd expected at most, %zd requested", fblk_nrvars, req_nrvars);
return -1; return -1;
} }
@ -1860,7 +1857,7 @@ static int prepare_new_context (hcl_t* hcl, hcl_oop_block_t rcv_blk, hcl_ooi_t n
} }
#else #else
blkctx->ip = rcv_blk->ip; blkctx->ip = rcv_blk->ip;
blkctx->flags = rcv_blk->flags; blkctx->req_nrets = HCL_SMOOI_TO_OOP(req_nrvars);
blkctx->tmpr_mask = rcv_blk->tmpr_mask; blkctx->tmpr_mask = rcv_blk->tmpr_mask;
blkctx->receiver_or_base = (hcl_oop_t)rcv_blk; blkctx->receiver_or_base = (hcl_oop_t)rcv_blk;
blkctx->home = rcv_blk->home; blkctx->home = rcv_blk->home;
@ -1965,7 +1962,7 @@ static int __activate_function (hcl_t* hcl, hcl_oop_function_t rcv_func, hcl_ooi
if (HCL_UNLIKELY(!functx)) return -1; if (HCL_UNLIKELY(!functx)) return -1;
functx->ip = HCL_SMOOI_TO_OOP(0); functx->ip = HCL_SMOOI_TO_OOP(0);
functx->flags = rcv_func->flags; functx->req_nrets = HCL_SMOOI_TO_OOP(1);
functx->tmpr_mask = rcv_func->tmpr_mask; functx->tmpr_mask = rcv_func->tmpr_mask;
functx->receiver_or_base = (hcl_oop_t)rcv_func; functx->receiver_or_base = (hcl_oop_t)rcv_func;
functx->home = rcv_func->home; functx->home = rcv_func->home;
@ -2290,7 +2287,7 @@ static int start_initial_process_and_context (hcl_t* hcl, hcl_ooi_t initial_ip,
hcl->sp = -1; hcl->sp = -1;
ctx->ip = HCL_SMOOI_TO_OOP(initial_ip); ctx->ip = HCL_SMOOI_TO_OOP(initial_ip);
ctx->flags = HCL_SMOOI_TO_OOP(0); ctx->req_nrets = HCL_SMOOI_TO_OOP(1);
ctx->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask); ctx->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask);
ctx->origin = ctx; /* the origin of the initial context is itself as this is created over the initial function */ ctx->origin = ctx; /* the origin of the initial context is itself as this is created over the initial function */
ctx->home = hcl->initial_function->home; /* this should be nil */ ctx->home = hcl->initial_function->home; /* this should be nil */
@ -3117,6 +3114,37 @@ static int execute (hcl_t* hcl)
/* -------------------------------------------------------- */ /* -------------------------------------------------------- */
case HCL_CODE_PUSH_RETURN_R:
{
hcl_oop_context_t ctx;
hcl_oow_t i;
hcl_ooi_t tmpr_mask, fixed_nargs;
LOG_INST_0 (hcl, "push_return_r");
HCL_ASSERT(hcl, HCL_IS_CONTEXT(hcl, hcl->active_context));
ctx = hcl->active_context;
tmpr_mask = HCL_OOP_TO_SMOOI(ctx->tmpr_mask);
fixed_nargs = GET_BLKTMPR_MASK_NARGS(tmpr_mask);
i = HCL_OOP_TO_SMOOI(ctx->req_nrets);
/* return variables are placed after the fixed arguments */
while (i > 0)
{
--i;
HCL_STACK_PUSH (hcl, ctx->slot[fixed_nargs + i]);
}
/* same as HCL_CODE_RETURN_FROM_BLOCK */
hcl->last_retv = HCL_STACK_GETTOP(hcl); /* get the stack top */
do_return_from_block (hcl);
break;
}
case HCL_CODE_CALL_R: case HCL_CODE_CALL_R:
{ {
hcl_oop_t rcv; hcl_oop_t rcv;
@ -3165,7 +3193,7 @@ static int execute (hcl_t* hcl)
break; break;
case HCL_BRAND_BLOCK: case HCL_BRAND_BLOCK:
if (activate_block(hcl, b1, 0) <= -1) goto call_failed; if (activate_block(hcl, b1, 1) <= -1) goto call_failed;
break; break;
case HCL_BRAND_PRIM: case HCL_BRAND_PRIM:

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

@ -831,13 +831,14 @@ enum hcl_bcode_t
HCL_CODE_CALL_X = 0xD4, /* 212 ## */ HCL_CODE_CALL_X = 0xD4, /* 212 ## */
HCL_CODE_CALL_R = 0xD5, /* 213 ## ##*/ HCL_CODE_CALL_R = 0xD5, /* 213 ## ##*/
HCL_CODE_TRY_ENTER = 0xD6, /* 214 ## */ HCL_CODE_PUSH_RETURN_R = 0xD6, /* 214 */
HCL_CODE_TRY_ENTER2 = 0xD7, /* 215 ## */ HCL_CODE_TRY_ENTER = 0xD7, /* 215 ## */
HCL_CODE_STORE_INTO_CTXTEMPVAR_X = 0xD8, /* 216 ## */ HCL_CODE_STORE_INTO_CTXTEMPVAR_X = 0xD8, /* 216 ## */
HCL_CODE_TRY_EXIT = 0xD9, /* 217 */ HCL_CODE_TRY_ENTER2 = 0xD9, /* 217 ## */
HCL_CODE_THROW = 0xDA, /* 218 */ HCL_CODE_TRY_EXIT = 0xDA, /* 218 */
/* UNUSED - 0xDB - 0xDB */ HCL_CODE_THROW = 0xDB, /* 219 */
HCL_CODE_POP_INTO_CTXTEMPVAR_X = 0xDC, /* 220 ## */ HCL_CODE_POP_INTO_CTXTEMPVAR_X = 0xDC, /* 220 ## */
/* UNUSED - 0xDD - 0xDF */ /* UNUSED - 0xDD - 0xDF */

10
hcl/lib/hcl.h
View File

@ -549,11 +549,11 @@ struct hcl_fpdec_t
#define HCL_FUNCTION_GET_CODE_BYTE(m) HCL_OBJ_GET_TRAILER_BYTE(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_FUNCTION_GET_CODE_SIZE(m) HCL_OBJ_GET_TRAILER_SIZE(m)
#define HCL_FUNCTION_NAMED_INSTVARS 4 /* this excludes literal frames and byte codes */ #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_function_t;
typedef struct hcl_function_t* hcl_oop_function_t; typedef struct hcl_function_t* hcl_oop_function_t;
#define HCL_BLOCK_NAMED_INSTVARS 4 #define HCL_BLOCK_NAMED_INSTVARS 3
typedef struct hcl_block_t hcl_block_t; typedef struct hcl_block_t hcl_block_t;
typedef struct hcl_block_t* hcl_oop_block_t; typedef struct hcl_block_t* hcl_oop_block_t;
@ -567,7 +567,6 @@ struct hcl_function_t
{ {
HCL_OBJ_HEADER; HCL_OBJ_HEADER;
hcl_oop_t flags;
hcl_oop_t tmpr_mask; /* smooi */ hcl_oop_t tmpr_mask; /* smooi */
hcl_oop_context_t home; /* home context. nil for the initial function */ hcl_oop_context_t home; /* home context. nil for the initial function */
@ -587,7 +586,6 @@ struct hcl_block_t
{ {
HCL_OBJ_HEADER; HCL_OBJ_HEADER;
hcl_oop_t flags;
hcl_oop_t tmpr_mask; /* smooi */ hcl_oop_t tmpr_mask; /* smooi */
hcl_oop_context_t home; /* home context */ hcl_oop_context_t home; /* home context */
hcl_oop_t ip; /* smooi. instruction pointer where the byte code begins in home->origin */ hcl_oop_t ip; /* smooi. instruction pointer where the byte code begins in home->origin */
@ -597,8 +595,8 @@ struct hcl_context_t
{ {
HCL_OBJ_HEADER; HCL_OBJ_HEADER;
/* SmallInteger, context flags */ /* SmallInteger */
hcl_oop_t flags; hcl_oop_t req_nrets;
/* SmallInteger. */ /* SmallInteger. */
hcl_oop_t tmpr_mask; hcl_oop_t tmpr_mask;