making return-from-home more rewind friendly
This commit is contained in:
parent
f4661d018a
commit
fb46b058d7
208
lib/exec.c
208
lib/exec.c
@ -2909,103 +2909,6 @@ switch_to_next:
|
|||||||
|
|
||||||
/* ------------------------------------------------------------------------- */
|
/* ------------------------------------------------------------------------- */
|
||||||
|
|
||||||
static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value)
|
|
||||||
{
|
|
||||||
/* 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) */
|
|
||||||
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 */
|
|
||||||
|
|
||||||
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 */
|
|
||||||
}
|
|
||||||
|
|
||||||
terminate_process (hcl, hcl->processor->active);
|
|
||||||
}
|
|
||||||
/*else if (hcl->active_context->home == hcl->processor->active->initial_context) // read the interactive mode note below...*/
|
|
||||||
else if ((hcl_oop_t)hcl->active_context->home->home == hcl->_nil)
|
|
||||||
{
|
|
||||||
/* non-local return out of the initial context
|
|
||||||
* (defun y(x) (return-from-home (* x x)))
|
|
||||||
* (y 999) */
|
|
||||||
|
|
||||||
/* [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 againt
|
|
||||||
* 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 */
|
|
||||||
|
|
||||||
if (hcl->sp >= 0)
|
|
||||||
{
|
|
||||||
/* return-from-home has been called from where it shouldn't be
|
|
||||||
* (defun y(x) (return-from-home (* x x)))
|
|
||||||
* (printf "xxx %d\n" (y 999)) */
|
|
||||||
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_WARN, "Warning - stack not empty on non-local return-from-home - SP %zd\n", hcl->sp); /* TODO: include line number and file name */
|
|
||||||
}
|
|
||||||
|
|
||||||
terminate_process (hcl, hcl->processor->active);
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
/*
|
|
||||||
(defun f(x)
|
|
||||||
(defun y(x) (return-from-home (* x x)))
|
|
||||||
(y x)
|
|
||||||
(printf "this line must not be printed\n");
|
|
||||||
)
|
|
||||||
(printf "%d\n" (f 90)) ; this should print 8100.
|
|
||||||
(y 10); this ends up with the "unable to return from dead context" error.
|
|
||||||
*/
|
|
||||||
HCL_ASSERT (hcl, hcl->active_context != hcl->processor->active->initial_context);
|
|
||||||
HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->home->sender != hcl->_nil);
|
|
||||||
|
|
||||||
if (hcl->active_context->home->ip == HCL_SMOOI_TO_OOP(-1))
|
|
||||||
{
|
|
||||||
HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return from dead context\n");
|
|
||||||
hcl_seterrbfmt (hcl, HCL_EINTERN, "unable to return from dead context"); /* TODO: can i make this error catchable at the hcl level? */
|
|
||||||
return -1;
|
|
||||||
}
|
|
||||||
|
|
||||||
hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that this 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);
|
|
||||||
|
|
||||||
/* push the return value to the stack of the new active context */
|
|
||||||
HCL_STACK_PUSH (hcl, return_value);
|
|
||||||
|
|
||||||
#if 0
|
|
||||||
/* stack dump */
|
|
||||||
HCL_DEBUG1 (hcl, "****** non local returning %O\n", return_value);
|
|
||||||
{
|
|
||||||
int i;
|
|
||||||
for (i = hcl->sp; i >= 0; i--)
|
|
||||||
{
|
|
||||||
HCL_DEBUG2 (hcl, "STACK[%d] => %O\n", i, HCL_STACK_GET(hcl, i));
|
|
||||||
}
|
|
||||||
}
|
|
||||||
#endif
|
|
||||||
}
|
|
||||||
|
|
||||||
return 0;
|
|
||||||
}
|
|
||||||
|
|
||||||
static HCL_INLINE void do_return_from_block (hcl_t* hcl)
|
static HCL_INLINE void do_return_from_block (hcl_t* hcl)
|
||||||
{
|
{
|
||||||
/*if (hcl->active_context == hcl->processor->active->initial_context)*/
|
/*if (hcl->active_context == hcl->processor->active->initial_context)*/
|
||||||
@ -3092,6 +2995,117 @@ static HCL_INLINE void do_return_from_block (hcl_t* hcl)
|
|||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
||||||
|
static HCL_INLINE int do_return_from_home (hcl_t* hcl, hcl_oop_t return_value)
|
||||||
|
{
|
||||||
|
/* 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) */
|
||||||
|
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 */
|
||||||
|
|
||||||
|
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 */
|
||||||
|
}
|
||||||
|
|
||||||
|
terminate_process (hcl, hcl->processor->active);
|
||||||
|
}
|
||||||
|
/*else if (hcl->active_context->home == hcl->processor->active->initial_context) // read the interactive mode note below...*/
|
||||||
|
else if ((hcl_oop_t)hcl->active_context->home->home == hcl->_nil)
|
||||||
|
{
|
||||||
|
/* non-local return out of the initial context
|
||||||
|
* (defun y(x) (return-from-home (* x x)))
|
||||||
|
* (y 999) */
|
||||||
|
|
||||||
|
/* [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 againt
|
||||||
|
* 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 */
|
||||||
|
|
||||||
|
if (hcl->sp >= 0)
|
||||||
|
{
|
||||||
|
/* return-from-home has been called from where it shouldn't be
|
||||||
|
* (defun y(x) (return-from-home (* x x)))
|
||||||
|
* (printf "xxx %d\n" (y 999)) */
|
||||||
|
HCL_LOG1 (hcl, HCL_LOG_IC | HCL_LOG_WARN, "Warning - stack not empty on non-local return-from-home - SP %zd\n", hcl->sp); /* TODO: include line number and file name */
|
||||||
|
}
|
||||||
|
|
||||||
|
terminate_process (hcl, hcl->processor->active);
|
||||||
|
}
|
||||||
|
else
|
||||||
|
{
|
||||||
|
hcl_oop_context_t sender;
|
||||||
|
|
||||||
|
/*
|
||||||
|
(defun f(x)
|
||||||
|
(defun y(x) (return-from-home (* x x)))
|
||||||
|
(y x)
|
||||||
|
(printf "this line must not be printed\n");
|
||||||
|
)
|
||||||
|
(printf "%d\n" (f 90)) ; this should print 8100.
|
||||||
|
(y 10); this ends up with the "unable to return from dead context" error.
|
||||||
|
*/
|
||||||
|
HCL_ASSERT (hcl, hcl->active_context != hcl->processor->active->initial_context);
|
||||||
|
HCL_ASSERT (hcl, (hcl_oop_t)hcl->active_context->home->sender != hcl->_nil);
|
||||||
|
|
||||||
|
if (hcl->active_context->home->ip == HCL_SMOOI_TO_OOP(-1))
|
||||||
|
{
|
||||||
|
HCL_LOG0 (hcl, HCL_LOG_IC | HCL_LOG_ERROR, "Error - cannot return from dead context\n");
|
||||||
|
hcl_seterrbfmt (hcl, HCL_EINTERN, "unable to return from dead context"); /* TODO: can i make this error catchable at the hcl level? */
|
||||||
|
return -1;
|
||||||
|
}
|
||||||
|
|
||||||
|
#if 0
|
||||||
|
hcl->active_context->home->ip = HCL_SMOOI_TO_OOP(-1); /* mark that this 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 */
|
||||||
|
HCL_STACK_PUSH (hcl, return_value);
|
||||||
|
|
||||||
|
#if 0
|
||||||
|
/* stack dump */
|
||||||
|
HCL_DEBUG1 (hcl, "****** non local returning %O\n", return_value);
|
||||||
|
{
|
||||||
|
int i;
|
||||||
|
for (i = hcl->sp; i >= 0; i--)
|
||||||
|
{
|
||||||
|
HCL_DEBUG2 (hcl, "STACK[%d] => %O\n", i, HCL_STACK_GET(hcl, i));
|
||||||
|
}
|
||||||
|
}
|
||||||
|
#endif
|
||||||
|
}
|
||||||
|
|
||||||
|
return 0;
|
||||||
|
}
|
||||||
|
|
||||||
/* ------------------------------------------------------------------------- */
|
/* ------------------------------------------------------------------------- */
|
||||||
|
|
||||||
static void xma_dumper (void* ctx, const char* fmt, ...)
|
static void xma_dumper (void* ctx, const char* fmt, ...)
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user