Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1447.mcz
==================== Summary ====================
Name: Kernel-jar.1447 Author: jar Time: 22 February 2022, 8:18:05.479858 pm UUID: 3772b6a0-c6ab-634c-97bb-a82bda2ecb6a Ancestors: Kernel-eem.1444
#terminate - latest version working independently of the revised suspend semantics in the latest VMs; structured similarly as original versions of #terminate in Squeak 1.x thru 3.5
supersede Kernel-jar.1443; please remove Kernel-jar.1443, Kernel-jar.1442, Kernel-jar.1437, Kernel-jar.1436, Kernel-jar.1435, Kernel-jar.1426
=============== Diff against Kernel-eem.1444 ===============
Item was added: + ----- Method: Context>>releaseCriticalSection: (in category 'private') ----- + releaseCriticalSection: oldList + "Figure out if we are terminating a process that is in the ensure: block of a critical section. + In this case, if it hasn't made progress but is beyond the wait (which we can tell by the oldList + being one of the runnable lists, i.e. a LinkedList, not a Semaphore or Mutex, et al), then the ensure: + block needs to be run." + + | selectorJustSent | + (self method pragmaAt: #criticalSection) ifNil: [^self]. + (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self]. + selectorJustSent := self selectorJustSentOrSelf. + + "If still at the wait the ensure: block has not been activated, so signal to restore." + selectorJustSent == #wait ifTrue: + [self receiver signal]. + + "If still at the lock primitive and the lock primitive just acquired ownership (indicated by it answering false) + then the ensure block has not been activated, so explicitly run primitiveExitCriticalSection to unlock." + (selectorJustSent == #primitiveEnterCriticalSection + or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: + [(self stackPtr > 0 + and: [self top == false]) ifTrue: + [self receiver primitiveExitCriticalSection]]!
Item was added: + ----- Method: Context>>runUntilReturnFrom: (in category 'private-exceptions') ----- + runUntilReturnFrom: aContext + "Run the receiver (which must be its stack top context) until aContext returns. Avoid a context that cannot return. + Note: to avoid infinite recursion of MNU error inside unwind blocks, implement e.g. a wrapper around the message + sentTo: receiver in #doesNotUnderstand:. Note: This method is a trivialized version of #runUntilErrorOrReturnFrom: + and was intended to be used by #unwindTo as a helper method to unwind non-local returns inside unwind blocks." + + | here unwindBottom newTop | + here := thisContext. + "Avoid a context that cannot return (see Note 1 below)" + unwindBottom := (self findContextSuchThat: [:ctx | ctx selector = #cannotReturn:]) ifNil: [aContext]. + newTop := aContext sender. + "Insert ensure context under unwindBottom in self's stack (see Note 2 below)" + unwindBottom insertSender: (Context contextEnsure: [here jump]). + self jump. "Control jumps to the receiver's stack (see Note 2 below)" + "Control resumes here once the above inserted ensure block is executed (see #jump comments)" + ^newTop "Return the new top context (see Note 3 below)" + + "Note 1: returning from #cannotReturn's sender would crash the VM so we install a guard ensure context right + above it; after returning here the unwind will continue safely. Try running and debugging this example + (avoid Proceeding the BCR error though; it may indeed crash the image): + [[[] ensure: [^2]] ensure: [^42]] fork" + + "Note 2: the receiver (self) is run by jumping directly to it (the active process abandons thisContext and executes + self on its own stack; self must be its top context). However, before jumping to self we insert an ensure block under + unwindBottom context that will execute a jump back to thisContext when evaluated. The inserted guard ensure + context is removed once control jumps back to thisContext." + + "Note 3: it doesn't matter newTop is not a proper stack top context because #unwindTo will only use it as a starting + point in the search for the next unwind context and the computation will never return here. We could make newTop + a proper top context by pushing nil to its stack (^newTop push: nil) if need be (see #jump comments). + Cf. the pattern in #runUntilErrorOrReturnFrom:: removing the inserted ensure context by stepping until popped + when executing non-local returns wouldn't work here and would fail tests testTerminateInNestedEnsureWithReturn1 + through 4."!
Item was changed: ----- Method: Context>>unwindTo: (in category 'private-exceptions') ----- unwindTo: aContext + "Unwind the receiver to aContext to execute all pending unwind blocks."
+ self unwindTo: aContext safely: true! - | ctx unwindBlock | - ctx := self. - [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ - (ctx tempAt: 2) ifNil:[ - ctx tempAt: 2 put: true. - unwindBlock := ctx tempAt: 1. - unwindBlock value] - ]. - !
Item was added: + ----- Method: Context>>unwindTo:safely: (in category 'private-exceptions') ----- + unwindTo: aContext safely: aBoolean + "Unwind self to aContext to execute pending #ensure:/#ifCurtailed: argument blocks between self + and aContext. If aBoolean is false, unwind only blocks that have not run yet, otherwise complete all + pending unwind blocks including those currently in the middle of their execution; these blocks will + just finish their execution. Run all unwinds on their original stack using #runUntilReturnFrom:." + + | top ctx | + ctx := top := self. + aBoolean ifTrue: [ + "If self is a top context of a stack already halfways through an unwind, complete the outer-most + unfinished unwind block first; all nested pending unwind blocks will be completed in the process; + see testTerminationDuringUnwind and tests in ProcessTest/UnwindTest. + Note: Halfway-through blocks have already set the complete variable (ctxt tempAt: 2) in their + defining #ensure:/#ifCurtailed contexts from nil to true; we'll search for the bottom-most one." + | outerMost | + ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. + [ctx isNil] whileFalse: [ + (ctx tempAt:2) ifNotNil: [ + outerMost := ctx]. + ctx := ctx findNextUnwindContextUpTo: aContext]. + outerMost ifNotNil: [top := (top runUntilReturnFrom: outerMost) sender]]. + "By now no halfway-through unwind blocks are on the stack. + Note: top points to the former outerMost sender now, i.e. to the next context to be explored." + + ctx := top. + "#findNextUnwindContextUpTo: starts searching from the receiver's sender so we must check + the receiver explicitly whether it is an unwind context; see testTerminateEnsureAsStackTop. + Create a new top context (i.e. a new branch off the original stack) for each pending unwind block + (ctxt tempAt: 1) and execute it on the unwind block's stack to evaluate non-local returns correctly." + ctx isUnwindContext ifFalse: [ctx := ctx findNextUnwindContextUpTo: aContext]. + [ctx isNil] whileFalse: [ + (ctx tempAt: 2) ifNil: [ + ctx tempAt: 2 put: true. + top := (ctx tempAt: 1) asContextWithSender: ctx. "see the note below" + top runUntilReturnFrom: top]. + ctx := ctx findNextUnwindContextUpTo: aContext] + "Note: Cf. the unwind pattern in the previous versions of unwindTo: (1999-2021). Using #value + instead of #runUntilReturnFrom: lead to a failure to evaluate some non-local returns correctly; + a non-local return must be evaluated in the evaluation context (sender chain) in which it was defined."!
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; + allow all unwind blocks to run; if they are currently in progress, let them finish. + If the process is in the middle of a #critical: critical section, release it properly." + + "This is the kind of behavior we expect when terminating a healthy process. + See further comments in #terminateAggressively and #destroy methods dealing + with process termination when closing the debugger or after a catastrophic failure." + + "If terminating the active process, create a parallel stack and run unwinds from there; + if terminating a suspended process, again, create a parallel stack for the process being + terminated and resume the suspended process to complete its termination from the new + parallel stack. Use a priority higher than the active priority to make the process that + invoked the termination wait for its completion." - "Stop the receiver forever. - Run all unwind contexts (#ensure:/#ifCurtailed: blocks) on the stack, even if they are currently in progress. If already active unwind contexts should not be continued, send #terminateAggressively instead. - Note that ill unwind contexts are theoretically able to stall the termination (for instance, by placing a non-local return in an unwind block); however, this is a disrecommended practice. - If the process is in the middle of a critical section, release it properly."
+ "If terminating a suspended process (including runnable and blocked), always suspend + the terminating process first so it doesn't accidentally get woken up. Equally important is + the side effect of the suspension; In 2022 a new suspend semantics has been introduced: + the revised #suspend backs up a process waiting on a conditional variable to the send that + invoked the wait state, while the pre-2022 #suspend simply removed the process from + the conditional variable's list it was previously waiting on; see Process>>suspend comments. + Release any method marked with the <criticalSection> pragma via #releaseCriticalSection[:]. + Execute termination in the ensure argument block to ensure it completes even if the + terminator process itself gets terminated before it's finished; see testTerminateInTerminate." + + | context | - | ctxt unwindBlock oldList outerMost | self isActiveProcess ifTrue: [ + context := thisContext. + ^[context unwindTo: nil. self suspend] asContext jump]. - "If terminating the active process, suspend it first and terminate it as a suspended process." - [self terminate] fork. - ^self suspend].
+ [] ensure: [ | oldList | + oldList := myList. + self suspend. + context := suspendedContext ifNil: [^self]. + suspendedContext := [ + context releaseCriticalSection: oldList; unwindTo: nil. + self suspend] asContext. + self priority: Processor activePriority + 1; resume]! - "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]]]. - - "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]!