>From 9fac286524e8a9144aa7b741e1dd0c5d1c6e6dc8 Mon Sep 17 00:00:00 2001 From: Gwenael Casaccio Date: Tue, 15 Apr 2014 17:44:00 +0200 Subject: [PATCH 2/2] Add Process>>#isSuspendedInCCall It's not possible to make the difference between a suspended process and a process suspended by a C-Call. It's usefull to make the difference when the C-Call is reentrant (with GTK callbacks for instance). 2014-04-12 Gwenael Casaccio * kernel/ContextPart.st: Add ctxtFlags variable and check if ccall flag is set. * kernel/Process.st: Add isSuspendedInCCall. * libgst/dict.c: Add ctxtFlags in ContextPart declaration. * libgst/interp.c: Initialize ctxtFlags. * libgst/interp.h: Add ctxtFlags field in _gst_context_part, _gst_method_context and _gst_block_context. * libgst/interp-bc.inl: Initialize ctxtFlags. * libgst/prims.def: Set c call bit field context flags. --- ChangeLog | 12 ++++++++++ kernel/CCallable.st | 5 +++- kernel/ContextPart.st | 8 ++++++- kernel/Process.st | 6 +++++ libgst/dict.c | 4 ++-- libgst/interp-bc.inl | 5 ++++ libgst/interp.c | 13 +++++++++++ libgst/interp.h | 5 ++++ libgst/prims.def | 34 +++++++++++++++++++++++----- packages/kernel-tests/ChangeLog | 4 ++++ packages/kernel-tests/kernel/ProcessTests.st | 23 +++++++++++++++++++ 11 files changed, 109 insertions(+), 10 deletions(-) create mode 100644 packages/kernel-tests/kernel/ProcessTests.st diff --git a/ChangeLog b/ChangeLog index 4aa2f2c..1bf20f6 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2014-04-12 Gwenael Casaccio + + * kernel/ContextPart.st: Add ctxtFlags variable and check if ccall flag + is set. + * kernel/Process.st: Add isSuspendedInCCall. + * libgst/dict.c: Add ctxtFlags in ContextPart declaration. + * libgst/interp.c: Initialize ctxtFlags. + * libgst/interp.h: Add ctxtFlags field in _gst_context_part, + _gst_method_context and _gst_block_context. + * libgst/interp-bc.inl: Initialize ctxtFlags. + * libgst/prims.def: Set c call bit field context flags. + 2014-04-11 Gwenael Casaccio * kernel/Process.st: Change the process creation it set on the right diff --git a/kernel/CCallable.st b/kernel/CCallable.st index a937b61..85c8fa0 100644 --- a/kernel/CCallable.st +++ b/kernel/CCallable.st @@ -128,6 +128,8 @@ to perform the actual call-out to C routines.'> ] asyncCall [ + + "Perform the call-out for the function represented by the receiver. The arguments (and the receiver if one of the arguments has type #self or #selfSmalltalk) are taken from the parent context. @@ -140,7 +142,7 @@ to perform the actual call-out to C routines.'> ^self isValid ifFalse: [SystemExceptions.CInterfaceError signal: 'Invalid C call-out ' , self name] - ifTrue: [self asyncCallNoRetryFrom: thisContext parentContext] + ifTrue: [self asyncCallNoRetryFrom: thisContext parentContext ] ] asyncCallNoRetryFrom: aContext [ @@ -158,6 +160,7 @@ to perform the actual call-out to C routines.'> ] callInto: aValueHolder [ + "Perform the call-out for the function represented by the receiver. The arguments (and the receiver if one of the arguments has type #self or #selfSmalltalk) are taken from the parent context, and the diff --git a/kernel/ContextPart.st b/kernel/ContextPart.st index acccc48..b3c7a81 100644 --- a/kernel/ContextPart.st +++ b/kernel/ContextPart.st @@ -33,7 +33,7 @@ Object subclass: ContextPart [ - | parent nativeIP ip sp receiver method | + | parent nativeIP ip sp receiver method ctxtFlags | @@ -608,5 +608,11 @@ methods that can be used in inspection or debugging.'> self badReturnError ] + + isCCall [ + + ctxtFlags isInteger ifFalse: [^false]. + ^(ctxtFlags bitAnd: 1) == 1 + ] ] diff --git a/kernel/Process.st b/kernel/Process.st index 76d0742..020c3a1 100644 --- a/kernel/Process.st +++ b/kernel/Process.st @@ -422,6 +422,12 @@ can suspend themselves and resume themselves however they wish.'> ^suspendedContext isNil ] + isSuspendedInCCall [ + + + ^ self isSuspended and: [ self suspendedContext isCCall ] + ] + isWaiting [ "Answer whether the receiver is wating on a semaphore" diff --git a/libgst/dict.c b/libgst/dict.c index 8b37f0f..9ef8d5b 100644 --- a/libgst/dict.c +++ b/libgst/dict.c @@ -679,8 +679,8 @@ static const class_definition class_info[] = { "Metaclass", "instanceClass", NULL, NULL }, {&_gst_context_part_class, &_gst_object_class, - GST_ISP_POINTER, true, 6, - "ContextPart", "parent nativeIP ip sp receiver method ", + GST_ISP_POINTER, true, 7, + "ContextPart", "parent nativeIP ip sp receiver method ctxtFlags", NULL, NULL }, {&_gst_method_context_class, &_gst_context_part_class, diff --git a/libgst/interp-bc.inl b/libgst/interp-bc.inl index 8819481..4652925 100644 --- a/libgst/interp-bc.inl +++ b/libgst/interp-bc.inl @@ -304,6 +304,7 @@ _gst_send_message_internal (OOP sendSelector, /* Prepare new state. */ newContext = activate_new_context (header.stack_depth, sendArgs); + newContext->ctxtFlags = MCF_IS_METHOD_CONTEXT; newContext->flags = MCF_IS_METHOD_CONTEXT; /* push args and temps, set sp and _gst_temporaries */ prepare_context ((gst_context_part) newContext, sendArgs, header.numTemps); @@ -391,6 +392,7 @@ _gst_send_method (OOP methodOOP) /* prepare new state */ newContext = activate_new_context (header.stack_depth, sendArgs); + newContext->ctxtFlags = MCF_IS_METHOD_CONTEXT; newContext->flags = MCF_IS_METHOD_CONTEXT; /* push args and temps, set sp and _gst_temporaries */ prepare_context ((gst_context_part) newContext, sendArgs, header.numTemps); @@ -426,6 +428,7 @@ send_block_value (int numArgs, int cull_up_to) /* gc might happen - so reload everything. */ blockContext = (gst_block_context) activate_new_context (header.depth, numArgs); + blockContext->ctxtFlags = MCF_IS_METHOD_CONTEXT; closure = (gst_block_closure) OOP_TO_OBJ (closureOOP); blockContext->outerContext = closure->outerContext; /* push args and temps */ @@ -522,6 +525,7 @@ _gst_interpret (OOP processOOP) monitor_byte_codes: SET_EXCEPT_FLAG (false); + finish_debugging_step = false; /* First, deal with any async signals. */ if (async_queue_enabled) @@ -540,6 +544,7 @@ monitor_byte_codes: { _gst_async_signal (single_step_semaphore); single_step_semaphore = NULL; + finish_debugging_step = true; } } diff --git a/libgst/interp.c b/libgst/interp.c index ab67daf..fe1464f 100644 --- a/libgst/interp.c +++ b/libgst/interp.c @@ -120,6 +120,7 @@ typedef struct interp_jmp_buf unsigned short suspended; unsigned char interpreter; unsigned char interrupted; + mst_Boolean debugged; OOP processOOP; } interp_jmp_buf; @@ -212,6 +213,7 @@ OOP _gst_this_method = NULL; /* Signal this semaphore at the following instruction. */ static OOP single_step_semaphore = NULL; +static mst_Boolean finish_debugging_step = false; /* CompiledMethod cache which memoizes the methods and some more information for each class->selector pairs. */ @@ -2246,6 +2248,7 @@ _gst_prepare_execution_environment (void) dummyContext->objClass = _gst_method_context_class; dummyContext->parentContext = _gst_nil_oop; dummyContext->method = _gst_get_termination_method (); + dummyContext->ctxtFlags = FROM_INT (0); dummyContext->flags = MCF_IS_METHOD_CONTEXT | MCF_IS_EXECUTION_ENVIRONMENT | MCF_IS_UNWIND_CONTEXT; @@ -2763,6 +2766,7 @@ push_jmp_buf (interp_jmp_buf *jb, int for_interpreter, OOP processOOP) jb->suspended = 0; jb->interpreter = for_interpreter; jb->interrupted = false; + jb->debugged = finish_debugging_step; _gst_register_oop (processOOP); reentrancy_jmp_buf = jb; } @@ -2777,6 +2781,15 @@ pop_jmp_buf (void) _gst_terminate_process (jb->processOOP); _gst_unregister_oop (jb->processOOP); + + finish_debugging_step = jb->debugged; + + if (jb->debugged == true) + { + SET_EXCEPT_FLAG (true); + suspend_process (jb->processOOP); + } + return jb->interrupted && reentrancy_jmp_buf; } diff --git a/libgst/interp.h b/libgst/interp.h index e286e47..78b4cfe 100644 --- a/libgst/interp.h +++ b/libgst/interp.h @@ -103,6 +103,7 @@ typedef struct gst_context_part stack */ OOP receiver; /* the receiver OOP */ OOP method; /* the method that we're executing */ + intptr_t ctxtFlags; /* flags */ OOP x; /* depends on the subclass */ OOP contextStack[1]; } *gst_context_part; @@ -117,6 +118,7 @@ typedef struct gst_method_context stack */ OOP receiver; /* the receiver OOP */ OOP method; /* the method that we're executing */ + intptr_t ctxtFlags; /* flags */ intptr_t flags; /* must be an int to distinguish gst_compiled_block/gst_method_context */ @@ -164,6 +166,8 @@ typedef struct method_cache_entry time of the call-in, and is the parent of the called-in method). */ #define MCF_IS_EXECUTION_ENVIRONMENT 8 +/* Anwser whether execution is going to be reentrant. */ +#define MCF_IS_REENTRANT 2 typedef struct gst_block_context { @@ -175,6 +179,7 @@ typedef struct gst_block_context stack */ OOP receiver; /* the receiver OOP */ OOP method; /* the method that we're executing */ + intptr_t ctxtFlags; /* flags */ OOP outerContext; /* the parent gst_block_context or gst_method_context */ OOP contextStack[1]; diff --git a/libgst/prims.def b/libgst/prims.def index a67c3fd..091ddf6 100644 --- a/libgst/prims.def +++ b/libgst/prims.def @@ -5213,9 +5213,13 @@ primitive VMpr_Behavior_primCompile [succeed] { OOP oop1; OOP oop2; + gst_method_context this_context; mst_Boolean interrupted; _gst_primitives_executed++; + this_context = (gst_method_context) OOP_TO_OBJ (_gst_this_context_oop); + this_context->ctxtFlags |= MCF_IS_REENTRANT; + oop2 = POP_OOP (); oop1 = POP_OOP (); if (IS_CLASS (oop2, _gst_string_class)) @@ -5231,6 +5235,8 @@ primitive VMpr_Behavior_primCompile [succeed] if (interrupted) stop_execution (); + else + this_context->ctxtFlags &= ~MCF_IS_REENTRANT; PRIM_SUCCEEDED; } @@ -5248,9 +5254,13 @@ primitive VMpr_Behavior_primCompileIfError [fail,succeed,reload_ip] oop1 = POP_OOP (); if (IS_CLASS (oop3, _gst_block_closure_class)) { + gst_method_context this_context; mst_Boolean oldReportErrors = _gst_report_errors; mst_Boolean interrupted; + this_context = (gst_method_context) OOP_TO_OBJ (_gst_this_context_oop); + this_context->ctxtFlags |= MCF_IS_REENTRANT; + if (oldReportErrors) { /* only clear out these guys on first transition */ @@ -5275,6 +5285,8 @@ primitive VMpr_Behavior_primCompileIfError [fail,succeed,reload_ip] else if (_gst_first_error_str != NULL) { + this_context->ctxtFlags &= ~MCF_IS_REENTRANT; + SET_STACKTOP (oop3); /* block context */ if (_gst_first_error_file != NULL) { @@ -5975,7 +5987,7 @@ primitive VMpr_FileDescriptor_socketOp [succeed,fail] primitive VMpr_CFuncDescriptor_asyncCall [succeed,fail] { OOP resultOOP; - volatile gst_method_context context; + volatile gst_method_context context, this_context; OOP contextOOP, cFuncOOP, receiverOOP; interp_jmp_buf jb; @@ -5997,8 +6009,13 @@ primitive VMpr_CFuncDescriptor_asyncCall [succeed,fail] cFuncOOP = STACKTOP (); push_jmp_buf (&jb, false, _gst_nil_oop); if (setjmp (jb.jmpBuf) == 0) - resultOOP = _gst_invoke_croutine (cFuncOOP, receiverOOP, - context->contextStack); + { + this_context = (gst_method_context) OOP_TO_OBJ (_gst_this_context_oop); + this_context->ctxtFlags |= MCF_IS_REENTRANT; + resultOOP = _gst_invoke_croutine (cFuncOOP, receiverOOP, + context->contextStack); + this_context->ctxtFlags &= ~MCF_IS_REENTRANT; + } else resultOOP = NULL; @@ -6021,7 +6038,7 @@ primitive VMpr_CFuncDescriptor_asyncCall [succeed,fail] primitive VMpr_CFuncDescriptor_call [succeed,fail] { - volatile gst_method_context context; + volatile gst_method_context context, this_context; gst_object resultHolderObj; OOP receiverOOP, contextOOP, cFuncOOP, resultOOP; volatile OOP resultHolderOOP; @@ -6051,8 +6068,13 @@ primitive VMpr_CFuncDescriptor_call [succeed,fail] push_jmp_buf (&jb, false, get_active_process ()); if (setjmp (jb.jmpBuf) == 0) - resultOOP = _gst_invoke_croutine (cFuncOOP, receiverOOP, - context->contextStack); + { + this_context = (gst_method_context) OOP_TO_OBJ (_gst_this_context_oop); + this_context->ctxtFlags |= MCF_IS_REENTRANT; + resultOOP = _gst_invoke_croutine (cFuncOOP, receiverOOP, + context->contextStack); + this_context->ctxtFlags &= ~MCF_IS_REENTRANT; + } else resultOOP = NULL; diff --git a/packages/kernel-tests/ChangeLog b/packages/kernel-tests/ChangeLog index d0557f3..5a8b821 100644 --- a/packages/kernel-tests/ChangeLog +++ b/packages/kernel-tests/ChangeLog @@ -1,3 +1,7 @@ +2014-04-11 Gwenael Casaccio + + * kernel/ProcessTests.st: Add new file. + 2014-02-06 Holger Hans Peter Freyther * kernel/CCallableTest.st: Add new file. diff --git a/packages/kernel-tests/kernel/ProcessTests.st b/packages/kernel-tests/kernel/ProcessTests.st new file mode 100644 index 0000000..65298fc --- /dev/null +++ b/packages/kernel-tests/kernel/ProcessTests.st @@ -0,0 +1,23 @@ +True extend [ + testCallin: aCallback [ + + ] +] + +TestCase subclass: TestProcess [ + + testCCallState [ + + + | p | + p := Processor activeProcess. + self assert: p isSuspendedInCCall not. + true + testCallin: (CCallbackDescriptor + for: [ :x | self assert: p isSuspendedInCCall. + 3 + ] + returning: #int + withArgs: #(#string)) + ] +] -- 1.8.3.2