The Trunk: Kernel-nice.1388.mcz

Nicolas Cellier uploaded a new version of Kernel to project The Trunk:
http://source.squeak.org/trunk/Kernel-nice.1388.mcz

==================== Summary ====================

Name: Kernel-nice.1388
Author: nice
Time: 15 April 2021, 9:51:03.805015 am
UUID: fafa2e33-6cf3-4999-a032-82c58be72905
Ancestors: Kernel-nice.1387, Kernel-jar.1386

Merge Kernel-jar.1386

        Fix a list of termination bugs described in http://forum.world.st/Solving-multiple-termination-bugs-summary-amp-proposal-td5128285.html

=============== Diff against Kernel-nice.1387 ===============

Item was changed:
  ----- Method: Process>>isSuspended (in category 'testing') -----
  isSuspended
+ "A process is suspended if it is not active, not terminated and
+ not waiting in a scheduler or a semaphore queue."
+
+ self isActiveProcess ifTrue: [^ false].
+ ^myList isNil and: [self isTerminated not]!
- "A process is suspended if it has been suspended with the suspend primitive.
- It is distinguishable from the active process and a terminated process by
- having a non-nil suspendedContext that is either not the bottom context
- or has not reached its endPC."
- ^nil == myList
-  and: [nil ~~ suspendedContext
-  and: [suspendedContext isBottomContext
- ifTrue: [suspendedContext closure
- ifNil: [suspendedContext methodClass ~~ Process
- or: [suspendedContext selector ~~ #terminate]]
- ifNotNil: [suspendedContext pc < suspendedContext closure endPC]]
- ifFalse: [true]]]!

Item was changed:
  ----- Method: Process>>isTerminated (in category 'testing') -----
  isTerminated
+ "Answer if the receiver is terminated. A process is considered terminated
+ if the suspendedContext is the bottomContext and the pc is at the endPC"
+
- "Answer if the receiver is terminated, or at least terminating."
  self isActiveProcess ifTrue: [^ false].
+ ^suspendedContext isNil or: [
+ suspendedContext isBottomContext and: [
+ suspendedContext isDead or: [suspendedContext atEnd]]]!
- ^suspendedContext isNil
-  or: ["If the suspendedContext is the bottomContext it is the block in Process>>newProcess.
-   If so, and the pc is at the endPC, the block has already sent and returned
-   from value and there is nothing more to do."
- suspendedContext isBottomContext
- and: [suspendedContext closure
- ifNil: [suspendedContext methodClass == Process
- and: [suspendedContext selector == #terminate]]
- ifNotNil: [suspendedContext pc >= suspendedContext closure endPC]]]!

Item was changed:
  ----- Method: Process>>terminate (in category 'changing process state') -----
  terminate
  "Stop the process that the receiver represents forever.
  Unwind to execute pending ensure:/ifCurtailed: blocks before terminating.
  If the process is in the middle of a critical: critical section, release it properly."
 
+ | ctxt unwindBlock oldList outerMost |
+ self isActiveProcess ifTrue: [
+ "If terminating the active process, suspend it first and terminate it as a suspended process."
+ [self terminate] fork.
+ ^self suspend].
- | ctxt unwindBlock oldList |
- self isActiveProcess ifTrue:
- [ctxt := thisContext.
- [ctxt := ctxt findNextUnwindContextUpTo: nil.
-  ctxt ~~ nil] whileTrue:
- [(ctxt tempAt: 2) ifNil:
- ["N.B. Unlike Context>>unwindTo: we do not set complete (tempAt: 2) to true."
- unwindBlock := ctxt tempAt: 1.
- thisContext terminateTo: ctxt.
- unwindBlock value]].
- thisContext terminateTo: nil.
- self suspend.
- "If the process is resumed this will provoke a cannotReturn: error.
- Would self debug: thisContext title: 'Resuming a terminated process' be better?"
- ^self].
 
  "Always suspend the process first so it doesn't accidentally get woken up.
  N.B. If oldList is a LinkedList then the process is runnable. If it is a Semaphore/Mutex et al
  then the process is blocked, and if it is nil then the process is already suspended."
  oldList := self suspend.
  suspendedContext ifNotNil:
  ["Release any method marked with the <criticalSection> pragma.
   The argument is whether the process is runnable."
  self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]).
 
+ "If terminating a process halfways through an unwind, try to complete that unwind block first;
+ if there are multiple such nested unwind blocks, try to complete the outer-most one; the inner
+ blocks will be completed in the process."
+ ctxt := suspendedContext.
+ [(ctxt := ctxt findNextUnwindContextUpTo: nil) isNil] whileFalse:
+ "Contexts under evaluation have already set their complete (tempAt: 2) to true."
+ [(ctxt tempAt:2) ifNotNil: [outerMost := ctxt]].
+ outerMost ifNotNil: [
+ "This is the outer-most unwind context currently under evaluation;
+ let's find an inner context executing outerMost's argument block (tempAt: 1)"
+ (suspendedContext findContextSuchThat: [:ctx |
+ ctx closure == (outerMost tempAt: 1)]) ifNotNil: [:inner |
+ "Let's finish the unfinished unwind context only (i.e. up to inner) and return here"
+ suspendedContext runUntilErrorOrReturnFrom: inner.
+ "Update the receiver's suspendedContext (the previous step reset its sender to nil);
+ return, if the execution stack reached its bottom (e.g. in case of non-local returns)."
+ (suspendedContext := outerMost sender) ifNil: [^self]]].
- "If terminating a process halfways through an unwind, try to complete that unwind block first."
- (suspendedContext findNextUnwindContextUpTo: nil) ifNotNil:
- [:outer|
- (suspendedContext findContextSuchThat:[:c| c closure == (outer tempAt: 1)]) ifNotNil:
- [:inner| "This is an unwind block currently under evaluation"
- suspendedContext runUntilErrorOrReturnFrom: inner]].
 
+ "Now all unwind blocks caught halfway through have been completed;
+ let's execute the ones still pending. Note: #findNextUnwindContextUpTo: starts
+ searching from the receiver's sender but the receiver itself may be an unwind context."
+ ctxt := suspendedContext.
+ ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil].
+ [ctxt isNil] whileFalse: [
+ (ctxt tempAt: 2) ifNil: [
+ ctxt tempAt: 2 put: true.
+ unwindBlock := ctxt tempAt: 1.
+ "Create a context for the unwind block and execute it on the unwind block's stack.
+ Note: using #value instead of #runUntilErrorOrReturnFrom: would lead to executing
+ the unwind on the wrong stack preventing the correct execution of non-local returns."
+ suspendedContext := unwindBlock asContextWithSender: ctxt.
+ suspendedContext runUntilErrorOrReturnFrom: suspendedContext].
+ ctxt := ctxt findNextUnwindContextUpTo: nil].
+
+ "Reset the context's pc and sender to nil for the benefit of isTerminated."
+ suspendedContext terminate]!
- ctxt := self popTo: suspendedContext bottomContext.
- ctxt == suspendedContext bottomContext ifFalse:
- [self debugWithTitle: 'Unwind error during termination' translated full: false].
- "Set the context to its endPC for the benefit of isTerminated."
- ctxt pc: ctxt endPC]!