diff --git a/lib/comp.c b/lib/comp.c index 6c4cb8d..cf9e955 100644 --- a/lib/comp.c +++ b/lib/comp.c @@ -3519,7 +3519,9 @@ static int compile_cons_xlist_expression (hcl_t* hcl, hcl_cnode_t* obj, int nret cf->u.call.index = nargs; cf->u.call.nrets = nrets; - /* arrange to push a dummy receiver to make the call look like a message send */ + /* arrange to push a dummy receiver to make the call look like a message send. + * if you change the dummy receiver instruction to something else, you must change + * the receiver value of the initial context in start_initial_process_and_context(), too */ PUSH_CFRAME (hcl, COP_EMIT_PUSH_NIL, car); /* <1> this will be executed the COP_COMPILE_OBJECT car frame */ } else diff --git a/lib/exec.c b/lib/exec.c index fb0f47f..d92f239 100644 --- a/lib/exec.c +++ b/lib/exec.c @@ -2017,14 +2017,14 @@ static HCL_INLINE int __activate_block (hcl_t* hcl, hcl_oop_block_t op_blk, hcl_ static HCL_INLINE int activate_block (hcl_t* hcl, hcl_ooi_t nargs, hcl_ooi_t nrvars) { - hcl_oop_block_t op; + hcl_oop_block_t op_blk; hcl_oop_context_t newctx; int x; - op = (hcl_oop_block_t)HCL_STACK_GETOP(hcl, nargs); - HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op)); + op_blk = (hcl_oop_block_t)HCL_STACK_GETOP(hcl, nargs); + HCL_ASSERT (hcl, HCL_IS_BLOCK(hcl, op_blk)); - x = __activate_block(hcl, op, nargs, nrvars, 0, 0, &newctx); + x = __activate_block(hcl, op_blk, nargs, nrvars, 0, 0, &newctx); if (HCL_UNLIKELY(x <= -1)) return -1; SWITCH_ACTIVE_CONTEXT (hcl, newctx); @@ -2361,7 +2361,7 @@ static void supplement_errmsg (hcl_t* hcl, hcl_ooi_t ip) static int do_throw_with_internal_errmsg (hcl_t* hcl, hcl_ooi_t ip) { hcl_oop_t ex; -/* TODO: considuer throwing an exception object instead of a string? */ +/* TODO: consider throwing an exception object instead of a string? */ ex = hcl_makestring(hcl, hcl->errmsg.buf, hcl->errmsg.len, 0); if (HCL_UNLIKELY(!ex)) { @@ -2594,9 +2594,9 @@ static int start_initial_process_and_context (hcl_t* hcl, hcl_ooi_t initial_ip, ctx->req_nrets = HCL_SMOOI_TO_OOP(1); ctx->tmpr_mask = HCL_SMOOI_TO_OOP(tmpr_mask); ctx->home = hcl->initial_function->home; /* this should be nil */ - ctx->sender = (hcl_oop_context_t)hcl->_nil; + ctx->sender = (hcl_oop_context_t)hcl->_nil; /* the initial context has nil in the sender field */ ctx->base = hcl->initial_function; - ctx->receiver = (hcl_oop_context_t)hcl->_nil; /* TODO: change this? keep this in sync with the fake receiver used in the call instruction */ + ctx->receiver = (hcl_oop_context_t)hcl->_nil; /* TODO: change this? keep this in sync with the dummy receiver used in the call instruction generated for xlist */ HCL_ASSERT (hcl, (hcl_oop_t)ctx->home == hcl->_nil); /* [NOTE] @@ -2909,7 +2909,7 @@ switch_to_next: /* ------------------------------------------------------------------------- */ -static HCL_INLINE void do_return_from_block (hcl_t* hcl) +static HCL_INLINE int do_return_from_block (hcl_t* hcl) { /*if (hcl->active_context == hcl->processor->active->initial_context)*/ if ((hcl_oop_t)hcl->active_context->home == hcl->_nil) @@ -2921,6 +2921,7 @@ static HCL_INLINE void do_return_from_block (hcl_t* hcl) HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->sender == hcl->_nil); hcl->active_context->ip = HCL_SMOOI_TO_OOP(-1); /* mark context dead */ terminate_process (hcl, hcl->processor->active); + return 1; /* indiate process termination */ } else { @@ -2988,20 +2989,31 @@ static HCL_INLINE void do_return_from_block (hcl_t* hcl) * class stack and exception stack. */ + HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->sender != hcl->_nil); + if (HCL_UNLIKELY(hcl->active_context->sender->ip == HCL_SMOOI_TO_OOP(-1))) + { + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return to dead context\n"); + hcl_seterrbfmt (hcl, HCL_EINTERN, "unable to return to dead context"); /* TODO: can i make this error catchable at the hcl level? */ + return -1; + } + /* it is a normal block return as the active block context * is not the initial context of a process */ hcl->ip = -1; /* mark context dead. saved into hcl->active_context->ip in SWITCH_ACTIVE_CONTEXT */ SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender); + return 0; /* normal return */ } } -static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value) +static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value, hcl_ooi_t ip) { +#if 0 /* if (hcl->active_context == hcl->processor->active->initial_context) // read the interactive mode note below... */ if ((hcl_oop_t)hcl->active_context->home == hcl->_nil) { /* returning from the intial context. - * (return-from-home 999) */ + * (return-from-home 999) + * the return-from-home is executed in the initial context */ HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->sender == hcl->_nil); hcl->active_context->ip = HCL_SMOOI_TO_OOP(-1); /* mark the active context dead */ @@ -3030,12 +3042,12 @@ static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value) * (defun y(x) (return-from-home (* x x))) <-- initial context * (y 999) <- another initial context * when y is called from the second initial context, the home context to return - * from the the first initial context. comparing hcl->active_context->home againt + * from the the first initial context. comparing hcl->active_context->home against * hcl->initial_context doesn't return true in this case. */ HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->home->sender == hcl->_nil); - hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that this context has returned */ + hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that the home context has returned */ if (hcl->sp >= 0) { @@ -3049,8 +3061,6 @@ static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value) } else { - hcl_oop_context_t sender; - /* (defun f(x) (defun y(x) (return-from-home (* x x))) @@ -3070,27 +3080,14 @@ static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value) return -1; } - #if 0 - hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that this context has returned */ - + hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that the home context has returned */ hcl->ip = -1; /* mark that the active context has returned. committed to hcl->active_context->ip in SWITCH_ACTIVE_CONTEXT() */ SWITCH_ACTIVE_CONTEXT (hcl, hcl->active_context->home->sender); - #else - sender = hcl->active_context->home->sender; - while (1) - { - do_return_from_block (hcl); - if (hcl->active_context == sender) - { - break; - } - } - #endif - /* push the return value to the stack of the new active context */ + /* push the return value to the stack of the final active context */ HCL_STACK_PUSH (hcl, return_value); -#if 0 + #if 0 /* stack dump */ HCL_DEBUG1 (hcl, "****** non local returning %O\n", return_value); { @@ -3100,9 +3097,98 @@ static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value) HCL_DEBUG2 (hcl, "STACK[%d] => %O\n", i, HCL_STACK_GET(hcl, i)); } } -#endif + #endif } +#else + + /* this part implements the non-local return by traversing the call chain + * until the sender of the home context is reached. + * it is slower than immediat return from the home context but detetts + * dead context better */ + + if ((hcl_oop_t)hcl->active_context->home == hcl->_nil) + { + /* non-local return from the intial context. + * (return-from-home 999) + */ + + /* the current active context must be the initial context of the active process */ + HCL_ASSERT (hcl, hcl->active_context == hcl->processor->active->initial_context); + HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->sender == hcl->_nil); + + hcl->active_context->ip = HCL_SMOOI_TO_OOP(-1); /* mark the active context dead */ + + term_proc: + if (hcl->sp >= 0) + { + /* return-from-home has been called from where it shouldn't be. for instance, + * (printf "xxx %d\n" (return-from-home 999)) + * ----------------------------------------------- + * (if (> 19 (return-from-home 20)) 30) */ + HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_WARN, "Warning - stack not empty on return-from-home - SP %zd\n", hcl->sp); /* TODO: include line number and file name */ + } + + /* as the process is terminated here, the nonempty stack or not invalidating the + * intermediates contexts deson't really matter. */ + terminate_process (hcl, hcl->processor->active); + } + else + { + hcl_oop_context_t sender, home, ctx; + + home = hcl->active_context->home; + sender = hcl->active_context->home->sender; + + /* check if the home context is in the current call chain */ + ctx = hcl->active_context; + while ((hcl_oop_t)ctx != hcl->_nil) + { + ctx = ctx->sender; + if (ctx == home) goto do_return; + } + + HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return from dead context - throwing an exception\n"); + hcl_seterrbfmt (hcl, HCL_EINTERN, "unable to return from dead context"); /* TODO: can i make this error catchable at the hcl level? */ + return do_throw_with_internal_errmsg(hcl, ip); + + do_return: + while (hcl->active_context != home) + { + hcl->ip = -1; /* mark context dead. saved into hcl->active_context->ip in SWITCH_ACTIVE_CONTEXT */ + SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender); + } + + if (HCL_UNLIKELY(sender == hcl->_nil)) + { + /* non-local return out of the initial context + * (defun y(x) (return-from-home (* x x))) + * (y 999) + * when y is activated, y's home context is itself. but the + * + * [NOTE] + * in the interactive mode, a new initial context/function/process is created + * for each expression (as implemented bin/main.c) + * hcl->active_context may be the intial context of the previous expression. + * (defun y(x) (return-from-home (* x x))) <-- initial context + * (y 999) <- another initial context + * when y is called from the second initial context, the home context to return + * from the the first initial context. comparing hcl->active_context->home against + * hcl->initial_context doesn't return true in this case. */ + HCL_ASSERT (hcl, home->home == hcl->_nil); + HCL_ASSERT (hcl, hcl->active_context->sender == hcl->_nil); + + home->ip = HCL_SMOOI_TO_OOP(-1); /* mark the home context dead */ + goto term_proc; + } + + HCL_ASSERT (hcl, hcl->active_context->sender == sender); + hcl->ip = -1; /* mark context dead. saved into hcl->active_context->ip in SWITCH_ACTIVE_CONTEXT */ + SWITCH_ACTIVE_CONTEXT (hcl, (hcl_oop_context_t)hcl->active_context->sender); + HCL_STACK_PUSH (hcl, return_value); + } +#endif + return 0; } @@ -4439,7 +4525,7 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1) handle_return: hcl->last_retv = return_value; - if (do_return_from_home(hcl, return_value) <= -1) goto oops; + if (do_return_from_home(hcl, return_value, fetched_instruction_pointer) <= -1) goto oops_with_errmsg_supplement; break; case HCL_CODE_RETURN_FROM_BLOCK: @@ -4536,7 +4622,6 @@ if (do_throw(hcl, hcl->_nil, fetched_instruction_pointer) <= -1) LOG_INST_0 (hcl, "noop"); break; - default: HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_FATAL, "Fatal error - unknown byte code 0x%zx\n", bcode); hcl_seterrnum (hcl, HCL_EINTERN);