>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