It is extremely confusing that Nabble strips of the revision number of the
changeset upon upload. :-)

---

Community service, here is the inlined diff:

"Change
Set:        SimulationSideEffectWarning
Date:            9
May 2021
Author:            Christoph
Thiede

<your descriptive text goes here>"

Warning subclass: #SimulationSideEffectWarning
    instanceVariableNames: 'primitiveIndex sender
suppressed'
    classVariableNames: ''
    poolDictionaries: ''
    category: 'Kernel-Exceptions'

I am signaled to notify the client of a simulation operation (i.e., a sender
of Context) about potential side effects that might occur when resuming the
simulation. See Context >> #doPrimitive:method:receiver:args:,
#messageText, and Parser >> #simulationGuard for more information.

doPrimitive: primitiveIndex method: meth receiver: receiver args: arguments
    "Simulate a primitive method whose index is
primitiveIndex.  The simulated receiver and
     arguments are given as arguments to this message.
If successful, push result and return
     resuming context, else ^ {errCode,
PrimitiveFailToken}. Any primitive which provokes
     execution needs to be intercepted and simulated to
avoid execution running away."

    | value |
    "Judicious use of primitive 19 (a null
primitive that doesn't do anything) prevents
     the debugger from entering various run-away
activities such as spawning a new
     process, etc.  Injudicious use results in the
debugger not being able to debug
     interesting code, such as the debugger itself. 
Hence use primitive 19 with care :-)"
    "SystemNavigation new browseAllSelect: [:m| m
primitive = 19]"
    primitiveIndex = 19 ifTrue: [
        [self notify: ('The code
being simulated is trying to control a process ({1}). Process controlling
cannot be simulated. If you proceed, things may happen outside the
observable area of the simulator.' translated format: {meth reference})]
            ifCurtailed:
[self push: nil "Cheap fix of the context's internal state"]].
    *"Test for unsimulatable side effects (that is,
code that will be triggered in the image outside of the simulator range).
This includes simulation guards, which are traditionally flagged using
primitive 19 (a null primitive that doesn't do anything), as well as certain
control primitives that might trigger code on other processes. If a side
effect is detected, raise a warning to give the user a chance to cancel the
operation."
    "#(19 87) do: [:primitive | self
systemNavigation browseAllSelect: [:m | m primitive = primitive]]"
    (primitiveIndex = 19 "simulationGuard" or:
[primitiveIndex = 87 "primitiveResume"]) ifTrue: [
        [SimulationSideEffectWarning
signalForPrimitive: primitiveIndex sender: self]
            ifCurtailed:
[self push: nil "Cheap fix of the context's internal state. Note that
unwinding the receiver -- so that the next step would invoke the primitive
again -- would be challenging due to to the variety of senders to this
method."]].*
    
    ((primitiveIndex between: 201 and: 222)
     and: [(self objectClass: receiver)
includesBehavior: BlockClosure]) ifTrue:
        [(primitiveIndex = 206
          or: [primitiveIndex =
208])
ifTrue:                        "[Full]BlockClosure>>valueWithArguments:"
            [^receiver
simulateValueWithArguments: arguments first caller: self].
         ((primitiveIndex between:
201 and:
209)            
"[Full]BlockClosure>>value[:value:...]"
          or: [primitiveIndex
between: 221 and: 222]) ifTrue:
"[Full]BlockClosure>>valueNoContextSwitch[:]"
            [^receiver
simulateValueWithArguments: arguments caller: self]].

    primitiveIndex = 83 ifTrue: "afr 9/11/1998
19:50" "Object>>perform:[with:...]"
        [| selector |
        selector := arguments at: 1
ifAbsent:
            [^
self class primitiveFailTokenFor: #'bad argument'].
        arguments size - 1 =
selector numArgs ifFalse:
            [^
self class primitiveFailTokenFor: #'bad number of arguments'].
        ^self send: selector to:
receiver with: arguments allButFirst].
    primitiveIndex = 84 ifTrue: "afr 9/11/1998
19:50 & eem 8/18/2009 17:04"
"Object>>perform:withArguments:"
        [| selector args |
        arguments size = 2 ifFalse:
            [^
self class primitiveFailTokenFor: #'bad argument'].
        selector := arguments first.
        args := arguments second.
        args isArray ifFalse:
            [^
self class primitiveFailTokenFor: #'bad argument'].
        args size = selector numArgs
ifFalse:
            [^
self class primitiveFailTokenFor: #'bad number of arguments'].
        ^self send: selector to:
receiver with: args].
    primitiveIndex = 100 ifTrue: "eem 8/18/2009
16:57" "Object>>perform:withArguments:inSuperclass:"
        [| rcvr selector args
superclass |
        arguments size
            caseOf:
{
                [3]
-> [
                    rcvr
:= receiver.
                    selector
:= arguments first.
                    args
:= arguments second.
                    superclass
:= arguments third].
                [4]
-> ["mirror primitive"
                    rcvr
:= arguments first.
                    selector
:= arguments second.
                    args
:= arguments third.
                    superclass
:= arguments fourth] }
            otherwise:
[^ self class primitiveFailTokenFor: #'bad argument'].
        args isArray ifFalse:
            [^
self class primitiveFailTokenFor: #'bad argument'].
        args size = selector numArgs
ifFalse:
            [^
self class primitiveFailTokenFor: #'bad number of arguments'].
        ((self objectClass: rcvr)
includesBehavior: superclass) ifFalse:
            [^
self class primitiveFailTokenFor: #'bad argument'].
        ^self send: selector to:
rcvr with: args lookupIn: superclass].

    "Mutex>>primitiveEnterCriticalSection
    
Mutex>>primitiveTestAndSetOwnershipOfCriticalSection"
    (primitiveIndex = 186 or: [primitiveIndex = 187])
ifTrue:
        [| effective |
         effective := Processor
activeProcess effectiveProcess.
         "active ==
effective"
         value := primitiveIndex =
186
                    ifTrue:
[receiver primitiveEnterCriticalSectionOnBehalfOf: effective]
                    ifFalse:
[receiver primitiveTestAndSetOwnershipOfCriticalSectionOnBehalfOf:
effective].
         ^(self isPrimFailToken:
value)
            ifTrue:
[value]
            ifFalse:
[self push: value]].

    primitiveIndex = 188
ifTrue:    "Object>>withArgs:executeMethod:
                                    CompiledMethod
class>>receiver:withArguments:executeMethod:
                                    VMMirror>>ifFail:object:with:executeMethod:
et al"
        [| n args methodArg
thisReceiver |
         ((n := arguments size)
between: 2 and: 4) ifFalse:
            [^self
class primitiveFailTokenFor: #'unsupported operation'].
         ((self objectClass: (args
:= arguments at: n - 1)) == Array
          and: [(self objectClass:
(methodArg := arguments at: n)) includesBehavior: CompiledMethod]) ifFalse:
            [^self
class primitiveFailTokenFor: #'bad argument'].
         methodArg numArgs = args
size ifFalse:
            [^self
class primitiveFailTokenFor: #'bad number of arguments'].
         thisReceiver := arguments
at: n - 2 ifAbsent: [receiver].
         methodArg primitive > 0
ifTrue:
            [methodArg
isQuick ifTrue:
                [^self
push: (methodArg valueWithReceiver: thisReceiver arguments: args)].
            
^self doPrimitive: methodArg primitive method: meth receiver: thisReceiver
args: args].
         ^Context
            sender:
self
            receiver:
thisReceiver
            method:
methodArg
            arguments:
args].

    primitiveIndex = 118 ifTrue:
"[receiver:]tryPrimitive:withArgs:; avoid recursing in the VM"
        [(arguments size = 3
          and: [(self objectClass:
arguments second) == SmallInteger
          and: [(self objectClass:
arguments last) == Array]]) ifTrue:
            [^self
doPrimitive: arguments second method: meth receiver: arguments first args:
arguments last].
         (arguments size = 2
         and: [(self objectClass:
arguments first) == SmallInteger
         and: [(self objectClass:
arguments last) == Array]]) ifFalse:
            [^self
class primitiveFailTokenFor: nil].
         ^self doPrimitive:
arguments first method: meth receiver: receiver args: arguments last].

    value := primitiveIndex = 120 "FFI method"
                ifTrue:
[(meth literalAt: 1) tryInvokeWithArguments: arguments]
                ifFalse:
                    [primitiveIndex
= 117 "named primitives"
                        ifTrue:
[self tryNamedPrimitiveIn: meth for: receiver withArgs: arguments]
                        ifFalse:
"should use self receiver: receiver tryPrimitive: primitiveIndex
withArgs: arguments but this is only in later VMs (and appears to be
broken)"
                            [receiver
tryPrimitive: primitiveIndex withArgs: arguments]].

    ^(self isPrimFailToken: value)
        ifTrue: [value]
        ifFalse: [self push: value]

invokeSimulationGuard
    <simulationGuard>
    "Nothing to see here, please move along!"
    ^ 42

testSimulationSideEffectWarningControl

    | warning |
    [Context runSimulated: [[] fork]] on:
SimulationSideEffectWarning do: [:ex |
        warning := ex].
    
    self assert: warning notNil.
    self assert: warning isControlPrimitive.
    self assert: warning suppressed.

testSimulationSideEffectWarningGuard

    | warning |
    [Context runSimulated: [self invokeSimulationGuard]]
on: SimulationSideEffectWarning do: [:ex |
        warning := ex].
    
    self assert: warning notNil.
    self assert: warning isSimulationGuard.
    self deny: warning suppressed.

testSimulationSideEffectWarningSuppress

    self
        shouldnt:
[(SimulationSideEffectWarning forPrimitive: 42 sender: thisContext)
            suppress;
            defaultAction]
raise: UnhandledWarning;
        should:
[(SimulationSideEffectWarning forPrimitive: 42 sender: thisContext)
            unsuppress;
            defaultAction]
raise: UnhandledWarning.

activeController: aController 
    "Set aController to be the currently active
controller. Give the user 
    control in it."
    <primitive: 19> "Simulation guard"
    *"Set aController to be the currently active
controller. Give the user control in it."
    <simulationGuard>*

    activeController := aController.
    (activeController == screenController)
        ifFalse: [self promote:
activeController].
    activeControllerProcess := 
            [activeController
startUp.
            self
searchForActiveController] newProcess.
    activeControllerProcess priority: Processor
userSchedulingPriority.
    activeControllerProcess resume

scheduleActive: aController 
    "Make aController be scheduled as the active
controller. Presumably the 
    active scheduling process asked to schedule this
controller and that a 
    new process associated this controller takes
control. So this is the last act 
    of the active scheduling process."
    <primitive: 19> "Simulation guard"
    *"Make aController be scheduled as the active
controller. Presumably the active scheduling process asked to schedule this
controller and that a new process associated this controller takes control.
So this is the last act of the active scheduling process."
    <simulationGuard>*

    self scheduleActiveNoTerminate: aController.
    Processor terminateActive

handleLabelUpdatesIn: aBlock whenExecuting: aContext
    "Send the selected message in the accessed
method, and regain control 
    after the invoked method returns."
    
    ^aBlock
        on: Notification
        do: [:ex|
            (ex
tag isArray
            
and: [ex tag size = 2
            
and: [(ex tag first == aContext or: [ex tag first hasSender: aContext])]])
                ifTrue:
                    [self
labelString: ex tag second description.
                    
ex resume]
                ifFalse:
                    [ex
pass]]
                    *[ex
pass]]
        on:
SimulationSideEffectWarning
        do: [:ex |
            ex
isControlPrimitive ifTrue: [ex unsuppress].
            ex
pass]*

simulationGuard
    "primitive 19 is a null primitive that always
fails. Just a marker for the simulator."
    <pragmaParser>

    self addPragma: (Pragma keyword: #primitive:
arguments: #(19)).
    
    self advance.
    ^ true

isControlPrimitive
    "See StackInterpreter
class>>#initializePrimitiveTable."

    ^ self primitive between: 80 and: 89

isSimulationGuard
    "See Parser >> #simulationGuard."

    ^ self primitive = 19

primitive

    ^ primitiveIndex

sender

    ^ sender

suppress

    suppressed := true.

suppressed

    ^ suppressed ifNil: [self isSimulationGuard not]

unsuppress

    suppressed := false.

primitive: anInteger sender: senderContext

    primitiveIndex := anInteger.
    sender := senderContext.

messageText

    ^ messageText ifNil: [
        'The code being simulated is
trying to control a process ({1}). {2}' translated format: {
            self
sender method reference.
            self
isSimulationGuard
                ifTrue:
['If you proceed, your image may become unusable. Continue at own risk, and
better save your image before.' translated]
                ifFalse:
['Process controlling cannot be simulated. If you proceed, side effects may
occur outside the observable area of the simulator.' translated]}]

defaultAction

    ^ self suppressed ifFalse: [super defaultAction]

forPrimitive: primitiveIndex sender: senderContext

    ^ self new primitive: primitiveIndex sender:
senderContext

signalForPrimitive: primitiveIndex sender: senderContext

    ^ (self forPrimitive: primitiveIndex sender:
senderContext) signal

('instance creation' forPrimitive:sender:)
('signaling' signalForPrimitive:sender:)


('testing' isControlPrimitive isSimulationGuard)
('accessing' primitive sender suppress suppressed unsuppress)
('initialize-release' primitive:sender:)
('printing' messageText)
('priv handling' defaultAction)


"Postscript:
CHANGELOG*:

- Replace generic Warning in Context >>
#doPrimitive:method:receiver:args: by specific warning of new class
SimulationSideEffectWarning.
- Also signal SimulationSideEffectWarning if primitive 87 (primitiveResume)
is hit.
- SimulationSideEffectWarning contains logic to detect the type (simulation
guard/control primitive) of the side effect. It can also be suppressed or
unsuppressed along the handler chain using the '*suppress*' selectors.
Control primitive side effects are suppressed by default.
- Add tests for the changes above.
- In the debugger, unsuppress control primitive warnings.
- Replace definitions of primitive 19 (currently only in ControlManager) by
a named alias pragma, <simulationGuard>, which is implemented on
Parser.

For more information, see:
http://forum.world.st/The-Trunk-Kernel-nice-1386-mcz-td5128636.html


(* Sorry, this should be in the preamble, not in the postscript, I know, but
the preamble editor in the ChangeSorter is currently broken.
¯\_(?)_/¯)
"




-----
Carpe Squeak!
--
Sent from: http://forum.world.st/Squeak-Dev-f45488.html
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://lists.squeakfoundation.org/pipermail/squeak-dev/attachments/20210509/a1ca34e3/attachment.html>