[Help-smalltalk] [PATCH] Allow CallinProcesses to be terminated safely

[Paolo Bonzini]

This is a severe bug (it is bug 158).

I had tried to fix it several times, and the other fixes required ugly 
Context games, lots of special casing in the C code, or building complex 
Smalltalk objects from within the C code.  They were too complicated and 
I never actually set to implement any of them.  This instead is the 
simplest fix that can possibly work: we do not need to use #on:do: to 
register an exception handler -- the special 
UndefinedObject>>#'__terminate' method can register it on its own.

A disadvantage of fixing the thing in the image, is that <=3.0.4 images 
will not have the bug fixed when run under 3.0.5.  But the simplicity of 
this fix offsets any disadvantage.

Applied to master and stable-3.0.

Paolo

2008-08-18  Paolo Bonzini  <address@hidden>

        * kernel/AnsiExcept.st: Register an exception handler within
        UndefinedObject>>#'__terminate'.
        * kernel/ContextPart.st: Scan the environment context too for
        #scanBacktraceForAttribute:do:.
        * tests/processes.st: Add testcase.
        * tests/processes.ok: Regenerate.

diff --git a/NEWS b/NEWS
index 6dfba3a..4a7b130 100644
--- a/NEWS
+++ b/NEWS
@@ -169,6 +169,8 @@ o   Swazoo web server.
 
 NEWS FROM 3.0.4 TO 3.0.5
 
+o   CallinProcesses can be terminated with Process>>#terminate.
+
 o   gst-doc implements a -F option to choose output format.  HTML and
     Texinfo are supported (contributed by Thomas Girard).
 
diff --git a/kernel/AnsiExcept.st b/kernel/AnsiExcept.st
index ef42002..97cfbe3 100644
--- a/kernel/AnsiExcept.st
+++ b/kernel/AnsiExcept.st
@@ -452,6 +452,28 @@ Notification subclass: ProcessBeingTerminated [
 
     | semaphore |
 
+    ProcessBeingTerminated class >> initialize [
+       (UndefinedObject>>#'__terminate')
+           descriptor: ((MethodInfo new: 1)
+               methodClass: UndefinedObject;
+               selector: #'__terminate';
+               at: 1 put: (Message
+                   selector: #exceptionHandlerSearch:reset:
+                   arguments: {
+                       [ :context :signal |
+                           (self handles: signal)
+                               ifTrue: [
+                                   signal
+                                       onDoBlock: nil
+                                       handlerBlock: [ :sig | thisContext 
environment continue: nil ]
+                                       onDoContext: nil
+                                       previousState: nil.
+                                   #found ]
+                               ifFalse: [nil] ].
+                       [ :context | ] });
+               yourself)
+    ]
+
     description [
        "Answer a textual description of the exception."
 
@@ -476,7 +498,6 @@ Notification subclass: ProcessBeingTerminated [
 
 ]
 
-
 
 Namespace current: SystemExceptions [
 
@@ -1558,6 +1579,7 @@ Object extend [
 
 
 Eval [
-    Exception initialize
+    Exception initialize.
+    SystemExceptions.ProcessBeingTerminated initialize
 ]
 
diff --git a/kernel/ContextPart.st b/kernel/ContextPart.st
index 6dd05c1..4ba50ef 100644
--- a/kernel/ContextPart.st
+++ b/kernel/ContextPart.st
@@ -418,12 +418,12 @@ methods that can be used in inspection or debugging.'>
        <category: 'enumerating'>
        | ctx attr |
        ctx := self.
-       [ctx isNil or: [ctx isEnvironment]] whileFalse: 
-               [(ctx isBlock not and: 
-                       [attr := ctx method attributeAt: selector ifAbsent: 
[nil].
-                       attr notNil]) 
-                   ifTrue: [aBlock value: ctx value: attr].
-               ctx := ctx parentContext]
+       [(ctx isBlock not and: 
+           [attr := ctx method attributeAt: selector ifAbsent: [nil].
+           attr notNil]) 
+               ifTrue: [aBlock value: ctx value: attr].
+
+       ctx isEnvironment or: [(ctx := ctx parentContext) isNil]] whileFalse
     ]
 
     scanBacktraceFor: selectors do: aBlock [
diff --git a/libgst/ChangeLog b/libgst/ChangeLog
index be4c3f3..9fbf50d 100644
--- a/libgst/ChangeLog
+++ b/libgst/ChangeLog
@@ -1,3 +1,7 @@
+2008-08-18  Paolo Bonzini  <address@hidden>
+
+       * libgst/comp.c: Mark the termination method as annotated.
+
 2008-08-17  Paolo Bonzini  <address@hidden>
 
        * libgst/prims.def: Add socket<->fd conversions.
diff --git a/libgst/comp.c b/libgst/comp.c
index 6545662..0e90230 100644
--- a/libgst/comp.c
+++ b/libgst/comp.c
@@ -460,6 +460,9 @@ _gst_install_initial_methods (void)
                                             _gst_terminate_symbol,
                                             _gst_this_category, -1, -1);
 
+  ((gst_compiled_method) OOP_TO_OBJ (termination_method))->header.headerFlag
+    = MTH_ANNOTATED;
+
   install_method (termination_method);
 
   methodsForString = "\
diff --git a/tests/processes.ok b/tests/processes.ok
index 86e7378..912d965 100644
--- a/tests/processes.ok
+++ b/tests/processes.ok
@@ -71,3 +71,6 @@ nil
 2
 2
 returned value is 2
+
+Execution begins...
+nothing should follow... returned value is nil
diff --git a/tests/processes.st b/tests/processes.st
index a61e419..0fadbbb 100644
--- a/tests/processes.st
+++ b/tests/processes.st
@@ -270,3 +270,12 @@ Eval [
     (Processor processEnvironment at: #a) printNl.
     b value printNl
 ]
+
+
+"Test that CallinProcesses can be terminated softly"
+Eval [
+    [ [ Processor activeProcess terminate ] ensure: [ '... ' display ] ]
+       on: SystemExceptions.ProcessBeingTerminated
+       do: [ :sig | 'nothing should follow' display. sig pass ].
+    'failed' displayNl
+]