Marcel Taeumel uploaded a new version of Kernel to project The Treated Inbox: http://source.squeak.org/treated/Kernel-jar.1468.mcz
==================== Summary ====================
Name: Kernel-jar.1468 Author: jar Time: 29 May 2022, 3:09:04.797182 pm UUID: ed2a10c6-957b-ef4b-88ed-e3bf53f65520 Ancestors: Kernel-dtl.1467
Update to accommodate the new suspend semantics using primitives 568 and 578.
Use new suspend primitive 579 but 568 could be used as well if preferred. The old primitive 88 has been moved to #suspendAndUnblock for convenience and backward compatibiity.
Update #terminate to be able to unblock and terminate processes being blocked on a condition variable.
This minimum set of changes is partly compatible with older VMs with only suspend primitive 88. For improved compatibility with older VMs #isTerminated would require to be updated as well.
To be complemented with a set of new and updated tests - coming soon.
Supersede Kernel-jar.1447; please remove it from the Inbox.
=============== Diff against Kernel-dtl.1467 ===============
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. + 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: DelayWaitTimeout>>signalWaitingProcess (in category 'signaling') ----- signalWaitingProcess "Release the given process from the semaphore it is waiting on. This method relies on running at highest priority so that it cannot be preempted by the process being released." beingWaitedOn := false. "Release the process but only if it is still waiting on its original list" process suspendingList == delaySemaphore ifTrue:[ expired := true. + process suspendAndUnblock; resume. - process suspend; resume. ]. !
Item was changed: ----- Method: Process>>signalException: (in category 'signaling') ----- signalException: anException "Signal an exception in the receiver process...if the receiver is currently suspended, the exception will get signaled when the receiver is resumed. If the receiver is blocked on a Semaphore, it will be immediately re-awakened and the exception will be signaled; if the exception is resumed, then the receiver will return to a blocked state unless the blocking Semaphore has excess signals" + - | oldList | "If we are the active process, go ahead and signal the exception" + self isActiveProcess ifTrue: [^anException signal]. - self isActiveProcess ifTrue: [^anException signal].
+ "Suspend myself first to ensure that I won't run away + in the midst of the following modifications." + self suspend. + suspendedContext := Context + sender: suspendedContext + receiver: anException + method: (anException class lookupSelector: #signal) + arguments: #(). + ^self resume! - "Suspend myself first to ensure that I won't run away in the - midst of the following modifications." - myList ifNotNil:[oldList := self suspend]. - - "Add a new method context to the stack that will signal the exception" - suspendedContext := Context - sender: suspendedContext - receiver: self - method: (self class lookupSelector: #pvtSignal:list:) - arguments: (Array with: anException with: oldList). - - "If we are on a list to run, then suspend and restart the receiver - (this lets the receiver run if it is currently blocked on a semaphore). If - we are not on a list to be run (i.e. this process is suspended), then when the - process is resumed, it will signal the exception" - - oldList ifNotNil: [self resume]!
Item was changed: ----- Method: Process>>suspend (in category 'changing process state') ----- suspend + "eem 1/3/2022 10:38: + Primitive. Suspend the receiver, aProcess, such that it can be executed again + by sending #resume. If the given process is not the active process, take it off + its corresponding list. If the list was not its run queue assume it was on some + condition variable (Semaphore, Mutex) and back up its pc to the send that + invoked the wait state the process entered. Hence when the process resumes + it will reenter the wait state. Answer the list the receiver was previously on iff + it was not active and not blocked, otherwise answer nil." + + <primitive: 578 error: ec> + "This is fallback code for VMs which only support the old primitiveSuspend 88. + Note: in this case some tests may fail and some methods assuming the revised + suspend semantics described above may not work entirely as expected (e.g. + Context >> #releaseCriticalSection or Process >> #signalException)." + ^self suspendAndUnblock! - "Primitive. Stop the process that the receiver represents in such a way - that it can be restarted at a later time (by sending the receiver the - message resume). If the receiver represents the activeProcess, suspend it. - Otherwise remove the receiver from the list of waiting processes. - The return value of this method is the list the receiver was previously on (if any)." - | oldList | - <primitive: 88> - "This is fallback code for VMs which only support the old primitiveSuspend which - would not accept processes that are waiting to be run." - myList ifNil:[^nil]. "this allows us to use suspend multiple times" - oldList := myList. - myList := nil. - oldList remove: self ifAbsent:[]. - ^oldList!
Item was added: + ----- Method: Process>>suspendAndReleaseCriticalSection (in category 'private') ----- + suspendAndReleaseCriticalSection + "Figure out if we are terminating a process that is in the ensure: block of a critical section. + 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." + + | oldList selectorJustSent | + "Suspend and unblock the receiver from a condition variable using suspend primitive #88. + It answers the list the receiver was on before the suspension." + oldList := self suspendAndUnblock. + (oldList isNil or: [oldList class == LinkedList]) ifFalse: [^self]. + + (suspendedContext method pragmaAt: #criticalSection) ifNil: [^self]. + selectorJustSent := suspendedContext selectorJustSentOrSelf. + + "If still at the wait the ensure: block has not been activated, so signal to restore." + selectorJustSent == #wait ifTrue: + [suspendedContext 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 primitiveExitCriticalSection to unlock." + (selectorJustSent == #primitiveEnterCriticalSection + or: [selectorJustSent == #primitiveTestAndSetOwnershipOfCriticalSection]) ifTrue: + [(suspendedContext stackPtr > 0 + and: [suspendedContext top == false]) ifTrue: + [suspendedContext receiver primitiveExitCriticalSection]]!
Item was added: + ----- Method: Process>>suspendAndUnblock (in category 'changing process state') ----- + suspendAndUnblock + "ar 12/7/2007 17:10: + Primitive. Stop the process that the receiver represents in such a way + that it can be restarted at a later time (by sending the receiver the + message resume). If the receiver represents the activeProcess, suspend it. + Otherwise remove the receiver from the list of waiting processes. + The return value of this method is the list the receiver was previously on (if any)." + + <primitive: 88 error: ec> + "ar 12/7/2007 17:10: + This is fallback code for VMs which only support the old primitiveSuspend which + would not accept processes that are waiting to be run." + ^myList ifNotNil: "this allows us to use suspend multiple times" + [:oldList| + myList := nil. + oldList remove: self ifAbsent: []. + oldList]!
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. + Execute the 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: [ + self suspendAndReleaseCriticalSection. + context := suspendedContext ifNil: [^self]. + suspendedContext := [context 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]!