On 14/04/2014 20:17, Gwenaël Casaccio wrote:
On 12/04/2014 11:15, Gwenaël Casaccio wrote:
Hi,
I've added Process>>#isSuspendedInCCall useful when you try
to make the difference between a suspended process and a process
to make a c-call which is reentrant.
Cheers,
Gwen
Don't apply it I've a better implementation not yet finished but here
are the big lines:
In the primitive I get the context (if it's a block I get the method
context in the outer context)
and I set or unset a bit in the flag.
Now I'm not sure the it's not the current context that should be
tagged and not the outer context
but that requires more changes in the vm.
Cheers,
Gwen
Here is the patch: I've add one slot to ContextPart (ctxtFlags) and
thisContext is tagged while
being reentrant. And few primitives (compile, ccall) are extended to tag
the context.
Gwen
>From 9fac286524e8a9144aa7b741e1dd0c5d1c6e6dc8 Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio <[email protected]>
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 <[email protected]>
* 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 <[email protected]>
+
+ * 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 <[email protected]>
* 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 [
+ <category: 'calling'>
+
"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 [
+ <category: 'calling'>
"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 |
<shape: #pointer>
<category: 'Language-Implementation'>
@@ -608,5 +608,11 @@ methods that can be used in inspection or debugging.'>
<primitive: VMpr_ContextPart_continue>
self badReturnError
]
+
+ isCCall [
+ <category: 'accessing'>
+ 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 [
+ <category: 'private'>
+
+ ^ 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 <[email protected]>
+
+ * kernel/ProcessTests.st: Add new file.
+
2014-02-06 Holger Hans Peter Freyther <[email protected]>
* 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 [
+ <cCall: 'testCallin' returning: #void args: #(#selfSmalltalk #cObject)>
+ ]
+]
+
+TestCase subclass: TestProcess [
+
+ testCCallState [
+ <category: 'testing'>
+
+ | 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
_______________________________________________
help-smalltalk mailing list
[email protected]
https://lists.gnu.org/mailman/listinfo/help-smalltalk
