From 9fac286524e8a9144aa7b741e1dd0c5d1c6e6dc8 Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio <gwenael.casaccio@gmail.com>
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  <gwenael.casaccio@gmail.com>

	* 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  <gwenael.casaccio@gmail.com>
+
+	* 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  <gwenael.casaccio@gmail.com>
 
 	* 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  <gwenael.casaccio@gmail.com>
+
+	* kernel/ProcessTests.st: Add new file.
+
 2014-02-06  Holger Hans Peter Freyther  <holger@moiji-mobile.com>
 
 	* 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

