From 9145fb429f7d5fdf6f77573c5b677ba2524c89cb Mon Sep 17 00:00:00 2001
From: Gwenael Casaccio <mrgwen@gmail.com>
Date: Tue, 25 Mar 2014 14:50:57 +0100
Subject: [PATCH 6/6] kernel: Change process creation In
 process>>onBlock:priority:suspended: the priority is correctly set, if the
 new process is suspended the current process is not yielded. A special
 context is created with it we are sure the ensure blocks are executed. If the
 priority is smaller than the active process when calling resume the new
 process is not activated but only added to the right priority queue.

2014-03-25  Gwenael Casaccio  <gwenael.casaccio@gmail.com>

        * kernel/Process.st: Change the process creation it set on the right
        priority queue, the previous implementation sets it on a wrong priority
        queue.
        * kernel/MthContext.st: Add a new MethodContext builder.
        * kernel/SysExcept.st: ProcessBeingTerminated>>defaultHandler will
        execute all the ensure blocks
---
 ChangeLog            |  9 +++++++
 kernel/MthContext.st | 17 ++++++++++++++
 kernel/Process.st    | 66 ++++++++++++++++++++--------------------------------
 kernel/SysExcept.st  |  5 ++++
 4 files changed, 56 insertions(+), 41 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e02e849..8d49047 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2014-03-25  Gwenael Casaccio  <gwenael.casaccio@gmail.com>
+
+	* kernel/Process.st: Change the process creation it set on the right
+	priority queue, the previous implementation sets it on a wrong priority
+	queue.
+	* kernel/MthContext.st: Add a new MethodContext builder.
+	* kernel/SysExcept.st: ProcessBeingTerminated>>defaultHandler will
+	execute all the ensure blocks.
+
 2014-03-24  Gwenael Casaccio  <gwenael.casaccio@gmail.com>
 
 	* kernel/Process.st: Use the correct namespace in
diff --git a/kernel/MthContext.st b/kernel/MthContext.st
index 4f6af36..00cafde 100644
--- a/kernel/MthContext.st
+++ b/kernel/MthContext.st
@@ -41,6 +41,23 @@ ContextPart subclass: MethodContext [
 bits of information about the execution environment, and contain the
 execution stack.'>
 
+    MethodContext class >> stack: size flags: anInteger method: aMethod ip: anIpInteger sp: anSpInteger [
+        <category: 'instance creation'>
+        
+        ^ (self new: size)
+            flag: anInteger method: aMethod ip: anIpInteger sp: anSpInteger;
+            yourself
+    ]
+
+    flag: anInteger method: aMethod ip: anIpInteger sp: anSpInteger [
+        <category: 'initialization'>
+        
+        flags := anInteger.
+        ip := anIpInteger.
+        sp := anSpInteger.
+        method := aMethod.
+    ]
+
     printOn: aStream [
 	"Print a representation for the receiver on aStream"
 
diff --git a/kernel/Process.st b/kernel/Process.st
index d5931fb..caad025 100644
--- a/kernel/Process.st
+++ b/kernel/Process.st
@@ -52,6 +52,21 @@ can suspend themselves and resume themselves however they wish.'>
 	    suspend: aBoolean
     ]
 
+    Process class >> termination [
+        <category: 'private'>
+
+        Termination isNil ifFalse: [ ^ Termination ].
+        ^ [
+            Termination isNil ifTrue: [ Termination := MethodContext 
+                                                                stack: 4 
+                                                                flags: 6 
+                                                                method: UndefinedObject>>#__terminate 
+                                                                ip: 0 
+                                                                sp: -1 ].
+            Termination
+          ] valueWithoutPreemption
+    ]
+
     debugger [
 	"Return the object in charge of debugging the receiver.  This always returns
 	 nil unless the DebugTools package is loaded."
@@ -366,47 +381,16 @@ can suspend themselves and resume themselves however they wish.'>
 		valueWithoutPreemption
     ]
 
-    onBlock: aBlockClosure at: aPriority suspend: aBoolean [
-	<category: 'private'>
-	"It is important to retrieve this before we start the
-	 process, because we want to choose whether to continue
-	 running the new process based on the *old* activePriority,
-	 not the one of the new process which is the maximum one."
-
-	| closure activePriority |
-	activePriority := Processor activePriority.
-	closure :=
-	    [[[
-		"#priority: is inlined for two reasons.  First, to be able to
-		 suspend the process, and second because we need to invert
-		 the test on activePriority!  This because here we may want to
-		 yield to the creator, while in #priority: we may want to yield
-		 to the process whose priority was changed."
-		priority := aPriority.
-		aBoolean
-		    ifTrue: [self suspend]
-		    ifFalse: [
-			aPriority < activePriority ifTrue: [ Processor yield ] ].
-		aBlockClosure value]
-			on: SystemExceptions.ProcessBeingTerminated
-			do: 
-			    [:sig | 
-			    "If we terminate in the handler, the 'ensure' blocks are not
-			     evaluated.  Instead, if the handler returns, the unwinding
-			     is done properly."
-
-			    sig return]] 
-			ensure: [self primTerminate]].
-
-	"Start the Process immediately so that we get into the
-	 #on:do: handler.  Otherwise, we will not be able to
-	 terminate the process with #terminate.  The #resume will
-         preempt the forking process."
-	suspendedContext := closure asContext: nil.
-	priority := Processor unpreemptedPriority.
-	self
-	    addToBeFinalized;
-	    resume
+    onBlock: aBlockClosure at: aPriority suspend: suspended [
+        <category: 'private'>
+
+        | closure |
+        closure := [ [ aBlockClosure value ] ensure: [ self primTerminate ] ].
+        suspendedContext := closure asContext: (self class termination) copy.
+        priority := aPriority.
+        self addToBeFinalized.
+        suspended ifTrue: [ ^ self ].
+        self resume
     ]
 
     isActive [
diff --git a/kernel/SysExcept.st b/kernel/SysExcept.st
index 1adcb6f..80d61a9 100644
--- a/kernel/SysExcept.st
+++ b/kernel/SysExcept.st
@@ -298,6 +298,11 @@ Notification subclass: ProcessBeingTerminated [
 	<category: 'accessing'>
 	semaphore := aSemaphore
     ]
+
+    defaultAction [
+        <category: 'accessing'>
+        thisContext environment continue: nil
+    ]
 ]
 
 ]
-- 
1.8.3.2

