The Inbox: Kernel-jar.1411.mcz

A new version of Kernel was added to project The Inbox:
http://source.squeak.org/inbox/Kernel-jar.1411.mcz

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

Name: Kernel-jar.1411
Author: jar
Time: 24 May 2021, 3:26:59.344073 pm
UUID: 10663cd1-f068-024f-a791-24209108196b
Ancestors: Kernel-nice.1402

Supersede Kernel-jar.1409; latest changes: fix unwind when #ensure is top context, fix typo in isRecursive: setter. This is a "final" version.

Complemented with tests: Tests-jar.465, ToolsTests-jar.105, KernelTests-jar.405

Please remove Kernel-jar.1409, Kernel-jar.1404, Kernel-jar.1410 and Tests-jar.448 from the Inbox.

Summary and discussion of the bugs and changes in #terminate: http://forum.world.st/Solving-multiple-termination-bugs-summary-amp-proposal-td5128285.html

Recent changes: Clean-up, extract repeating code to a new method #complete:to: to improve readability, resolve MessageNotUnderstood and BlockCannotReturn recursion problem, update comments, support unwind from nested errors.

Consistent with current ProcessTest >> #testNestedUnwind semantics for completing nested halfways-through unwind blocks during termination:

x1 := x2 := x3 := nil.
p:=[
                [
                        [ ] ensure: [ "halfway through completion when suspended"
                                [ ] ensure: [ "halfway through completion when suspended"
                                        Processor activeProcess suspend. "here the process gets terminated"
                                        x1 := true].
                                x2 := true]
                ] ensure: [ "not started yet when suspended"
                        x3 := true]
] fork.
Processor yield.
p terminate
self assert: x1 & x2 & x3.

Discussion regarding a proposal to change the current semantics: http://forum.world.st/The-semantics-of-halfway-executed-unwind-contexts-during-process-termination-td5129800.html

=============== Diff against Kernel-nice.1402 ===============

Item was changed:
  Error subclass: #BlockCannotReturn
+ instanceVariableNames: 'result deadHome isRecursive'
- instanceVariableNames: 'result deadHome'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'Kernel-Exceptions'!
 
  !BlockCannotReturn commentStamp: '<historical>' prior: 0!
  This class is private to the EHS implementation.  Its use allows for ensured execution to survive code such as:
 
  [self doThis.
  ^nil]
  ensure: [self doThat]
 
  Signaling or handling this exception is not recommended.!

Item was added:
+ ----- Method: BlockCannotReturn>>isRecursive (in category 'accessing') -----
+ isRecursive
+
+ ^isRecursive ifNil: [false]!

Item was added:
+ ----- Method: BlockCannotReturn>>isRecursive: (in category 'accessing') -----
+ isRecursive: aBoolean
+
+ isRecursive := aBoolean!

Item was changed:
  ----- Method: Context>>cannotReturn: (in category 'private-exceptions') -----
  cannotReturn: result
 
+ closureOrNil ifNotNil: [self cannotReturn: result to: self home sender.
+ [self cannotReturnRecursive: result to: self home sender.
+ self notify: '#cannotReturn: Invoking an infinite loop'.
+ true] whileTrue]. "loop back to prevent return and image crash when resumed"
- closureOrNil ifNotNil: [^ self cannotReturn: result to: self home sender].
  Processor debugWithTitle: 'Computation has been terminated!!' translated full: false.!

Item was added:
+ ----- Method: Context>>cannotReturnRecursive:to: (in category 'private-exceptions') -----
+ cannotReturnRecursive: result to: homeContext
+ "The receiver tried to return result to homeContext that no longer exists.
+ This is a repeated invocation of the BlockCannotReturn error."
+
+ ^BlockCannotReturn new
+ result: result;
+ deadHome: homeContext;
+ isRecursive: true;
+ signal!

Item was added:
+ ----- Method: Context>>runUnwindUntilErrorOrReturnFrom: (in category 'private') -----
+ runUnwindUntilErrorOrReturnFrom: aSender
+ "ASSUMES aSender is a sender of self.  Execute self's stack until aSender returns or an unhandled exception is raised.  Return a pair containing the new top context and a possibly nil exception.  The exception is not nil if it was raised before aSender returned and it was not handled.  The exception is returned rather than openning the debugger, giving the caller the choice of how to handle it."
+ "Self is run by jumping directly to it (the active process abandons thisContext and executes self).  However, before jumping to self we insert an ensure block under aSender that jumps back to thisContext when evaluated.  We also insert an exception handler under aSender that jumps back to thisContext when an unhandled exception is raised.  In either case, the inserted ensure and exception handler are removed once control jumps back to thisContext."
+
+ | error ctxt here topContext |
+ here := thisContext.
+
+ "Insert ensure and exception handler contexts under aSender"
+ error := nil.
+ ctxt := aSender insertSender: (Context
+ contextOn: UnhandledError do: [:ex |
+ error ifNil: [
+ error := ex exception.
+ topContext := thisContext.
+ here jump.
+ ex signalerContext restart "re-signal the error when jumped back"]
+ ifNotNil: [ex pass]
+ ]).
+ ctxt := ctxt insertSender: (Context
+ contextEnsure: [error ifNil: [
+ topContext := thisContext.
+ here jump]
+ ]).
+ self jump.  "Control jumps to self"
+
+ "Control resumes here once above ensure block or exception handler is executed"
+ ^ error ifNil: [
+ "No error was raised, remove ensure context by making its sender a top context"
+     topContext := ctxt sender push: nil.
+ {topContext. nil}
+
+ ] ifNotNil: [
+ "Error was raised, remove inserted above contexts then return signaler context"
+ aSender terminateTo: ctxt sender.  "remove above ensure and handler contexts"
+ {topContext. error}
+ ]!

Item was added:
+ ----- Method: Process>>complete:to: (in category 'private') -----
+ complete: topContext to: aContext
+ "Run topContext on behalf of self on topContext's stack until aContext is popped or an unhandled
+ error is raised. Return self's new top context. Note: topContext must be a stack top context.
+ This method is meant to be called primarily by Process>>#terminate."
+
+ | pair top error |
+ pair := Processor activeProcess
+ evaluate: [topContext runUnwindUntilErrorOrReturnFrom: aContext]
+ onBehalfOf: self.
+ top := pair first.
+ error := pair second.
+ "If an error was detected jump back to the debugged process and re-signal the error;
+ some errors may require a special care - see a note below."
+ error ifNotNil: [
+ error class == BlockCannotReturn and: [error isRecursive] and: [^top]. "do not jump back again"
+ error class == MessageNotUnderstood ifTrue: [error initialize]. "reset reachedDefaultHandler before jump"
+ top jump].
+ ^top
+
+ "Note: to prevent an infinite recursion of the MessageNotUnderstood error, reset reachedDefaultHandler before jumping back which will prevent #doesNotUnderstand: from resending the unknown message.
+ To prevent an infinite recursion of the BlockCannotReturn error, simply check its isRecursive variable whether it's a repeating invocation of the error."!

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."
 
+ | oldList top ctxt outerMost newTop unwindBlock |
+ "If terminating the active process, suspend it first and terminate it as a suspended process."
- | 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].
 
  "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."
- 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 ifNil: [^self]. "self is already terminated"
+ "Release any method marked with the <criticalSection> pragma.
+ The argument is whether the process is runnable."
+ self releaseCriticalSection: (oldList isNil or: [oldList class == LinkedList]).
- 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]).
 
+ top := suspendedContext.
+ suspendedContext := nil. "disable this process while running its stack in active process below"
+ "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; nested
+ unwind blocks will be completed in the process. Halfway-through blocks have already set the
+ complete variable (tempAt: 2) in their defining #ensure:/#ifCurtailed contexts from nil to true.
+ Note: #findNextUnwindContextUpTo: starts searching from the receiver's sender but the receiver
+ itself may be an unwind context."
+ ctxt := top.
+ ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil].
+ [ctxt isNil] whileFalse: [
+ (ctxt tempAt:2) ifNotNil: [
+ outerMost := ctxt].
+ ctxt := ctxt findNextUnwindContextUpTo: nil].
+ outerMost ifNotNil: [newTop := self complete: top to: outerMost].
- "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]]].
 
+ "By now no halfway-through unwind blocks are on the stack. Create a new top context for each
+ pending unwind block (tempAt: 1) and execute it on the unwind block's stack.
+ Note: using #value instead of #complete:to: would lead to incorrect evaluation of non-local returns.
+ Note: newTop sender points to the former outerMost sender, i.e. the next unexplored context."
+ ctxt := newTop ifNil: [top] ifNotNil: [newTop sender].
+ ctxt isUnwindContext ifFalse: [ctxt := ctxt findNextUnwindContextUpTo: nil].
+ [ctxt isNil] whileFalse: [
+ (ctxt tempAt: 2) ifNil: [
+ ctxt tempAt: 2 put: true.
+ unwindBlock := ctxt tempAt: 1.
+ top := unwindBlock asContextWithSender: ctxt.
+ self complete: top to: top].
+ ctxt := ctxt findNextUnwindContextUpTo: nil]!
- "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]!