Christoph Thiede uploaded a new version of Kernel to project The Trunk: http://source.squeak.org/trunk/Kernel-ct.1559.mcz
==================== Summary ====================
Name: Kernel-ct.1559 Author: ct Time: 3 March 2024, 7:49:53.952958 pm UUID: 12cceefa-01f6-fa46-917b-cc2ec6f91312 Ancestors: Kernel-ct.1558
Merges SimulationSideEffectWarning.5.cs (step 2/2): In Context>>doPrimitive:method:receiver:args:, replaces generic "simulation guard" warnings for undebuggable methods by new specific, suppressable SimulationSideEffectWarnings. Also warns when primitive 87 (primitiveResume) is hit. Refactors <primitive: 19> simulation guards into a named alias pragma <simulationGuard>.
Revision: Revise documentation and document emergence and usage of SimulationSideEffectWarning in Context>>runSimulated:.... Fix resumption value of SimulationSideEffectWarning when proceeding from a debugger. Avoid infinite recursion due to process-faithful debugging when debugging a SimulationSideEffectWarning from a debugger. Improves tests.
Step 2/2: After the new <simulationGuard> pragma has been added to the compiler (Compiler-ct.497), we can use it in the tests and the ST80 package.
Thanks to Marcel (mt) for the advice! See: https://lists.squeakfoundation.org/archives/list/squeak-dev%40lists.squeakfo...
=============== Diff against Kernel-ct.1558 ===============
Item was changed: ----- Method: Context class>>runSimulated: (in category 'simulation') ----- runSimulated: aBlock + "Simulate the execution of aBlock, until it ends or is curtailed. Answer the result it returns. + + If aBlock attempts any action that escapes the control of the simulator (e.g., resuming another process), signal a SimulationSideEffectWarning. The client of the simulator (i.e., the sender of this method) may handle those warnings to remain control, or otherwise, these actions are allowed. Examples: + Context runSimulated: [[] fork]. --> fork is executed + [Context runSimulated: [[] fork]] + on: SimulationSideEffectWarning + do: [:ex | + ex isControlPrimitive ifTrue: [ex return: #forbidden]. + ex pass]. --> fork is prevented" - "Simulate the execution of aBlock, until it ends or is curtailed. Answer the result it returns."
^thisContext runSimulated: aBlock contextAtEachStep: []
"Context runSimulated: [Pen new ifNotNil: [:pen| pen defaultNib: 5. 4 timesRepeat: [pen go: 100; turn: 90]]]"
"Here's a fun example, reaching into the computation to squash the Display>>fillWhite that mandala: begins with..." "thisContext runSimulated: [Pen new mandala: 45] contextAtEachStep: [:ctxt| ctxt selector == #fillWhite ifTrue: [ctxt scanFor: [:ign| ctxt willReturn]]]"!
Item was changed: ----- Method: Context>>doPrimitive:method:receiver:args: (in category 'private') ----- 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 | + "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/client a chance to cancel or virtualize the operation." + "#(19 87) do: [:primitive | self systemNavigation browseAllSelect: [:m | m primitive = primitive]]" + (primitiveIndex = 19 "simulationGuard" or: [primitiveIndex = 87 "primitiveResume"]) ifTrue: + [[(SimulationSideEffectWarning forPrimitive: primitiveIndex) + context: self method: meth receiver: receiver arguments: arguments; + signalIfSkipped: [^ self]] + ifCurtailed: + [self push: receiver "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."]]. - "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"]]. ((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']. ^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']. ^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 number of arguments']. args isArray ifFalse: [^ self class primitiveFailTokenFor: #'bad argument']. ((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 or: [primitiveIndex = 189]) ifTrue: [| n args methodArg thisReceiver | primitiveIndex caseOf: {[188 "primitiveExecuteMethodArgsArray"] -> ["Object>>withArgs:executeMethod: CompiledMethod class>>receiver:withArguments:executeMethod: VMMirror>>ifFail:object:with:executeMethod: et al" ((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']. thisReceiver := arguments at: n - 2 ifAbsent: [receiver]]. [189 "primitiveExecuteMethod"] -> ["Object>>executeMethod: Object>>with:...executeMethod:" (arguments size > 0) ifFalse: [^self class primitiveFailTokenFor: #'bad argument']. ((self objectClass: (methodArg := arguments atLast: 1)) includesBehavior: CompiledMethod) ifFalse: [^self class primitiveFailTokenFor: #'bad argument']. args := arguments allButLast. thisReceiver := receiver]}. methodArg numArgs = args size ifFalse: [^self class primitiveFailTokenFor: #'bad number of arguments']. methodArg primitive > 0 ifTrue: [methodArg isQuick ifTrue: [^self push: (methodArg valueWithReceiver: thisReceiver arguments: args)]. ^self doPrimitive: methodArg primitive method: methodArg receiver: thisReceiver args: args]. ^self activateMethod: methodArg withArgs: args receiver: thisReceiver].
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: -3]. ^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]!
Item was changed: ----- Method: Context>>runSimulated:contextAtEachStep: (in category 'system simulation') ----- runSimulated: aBlock contextAtEachStep: anotherBlock + "Simulate the execution of the argument, aBlock, until it ends or is curtailed. If any exception is signaled during the execution, simulate it being handled on the present caller stack. Evaluate anotherBlock with the current context prior to each instruction executed. Answer the simulated value of aBlock. + + If aBlock attempts any action that escapes the control of the simulator (e.g., resuming another process), signal a SimulationSideEffectWarning. The client of the simulator (i.e., the sender of this method) may handle those warnings to remain control, or otherwise, these actions are allowed. Examples: + Context runSimulated: [[] fork]. --> fork is executed + [Context runSimulated: [[] fork]] + on: SimulationSideEffectWarning + do: [:ex | + ex isControlPrimitive ifTrue: [ex return: #forbidden]. + ex pass]. --> fork is prevented" - "Simulate the execution of the argument, aBlock, until it ends or is curtailed. If any exception is signaled during the execution, simulate it being handled on the present caller stack. Evaluate anotherBlock with the current context prior to each instruction executed. Answer the simulated value of aBlock."
| current resume ensure | resume := false. "Affect the context stack of the receiver during the simulation of aBlock." current := aBlock asContextWithSender: self. "Insert outer context denoting the end of the simulation." ensure := (ensure := current) insertSender: (Context contextEnsure: [resume := true. ensure privSender: thisContext home sender]). (anotherBlock numArgs = 0 ifTrue: ["optimized" [resume]] ifFalse: ["stop execution on time, don't expose simulation details to caller" [current == ensure or: ["Context >> #resume:" current size >= 2 and: [(current at: 2) == ensure]]] ]) whileFalse: [anotherBlock cull: current. current := current step]. "Continue with the execution in the previous context." ^ current jump!
Item was added: + Warning subclass: #SimulationSideEffectWarning + instanceVariableNames: 'primitiveIndex context method receiver arguments suppressed' + classVariableNames: '' + poolDictionaries: '' + category: 'Kernel-Exceptions'! + + !SimulationSideEffectWarning commentStamp: 'ct 3/3/2024 19:17' prior: 0! + I am signaled to notify the client of the simulator (i.e., a sender of Context>>step) about potential side effects of the next instruction to be executed that would escape the control of the simulator. For example, I am signaled before the simulated code starts another process. See Context>>doPrimitive:method:receiver:args:, my messageText, and Parser>>simulationGuard for more information.!
Item was added: + ----- Method: SimulationSideEffectWarning class>>forPrimitive: (in category 'instance creation') ----- + forPrimitive: primitiveIndex + + ^ self new primitive: primitiveIndex!
Item was added: + ----- Method: SimulationSideEffectWarning>>arguments (in category 'accessing') ----- + arguments + + ^ arguments!
Item was added: + ----- Method: SimulationSideEffectWarning>>context (in category 'accessing') ----- + context + + ^ context!
Item was added: + ----- Method: SimulationSideEffectWarning>>context:method:receiver:arguments: (in category 'initialize-release') ----- + context: aContext method: aCompiledMethod receiver: rcvr arguments: args + + context := aContext. + method := aCompiledMethod. + receiver := rcvr. + arguments := args.!
Item was added: + ----- Method: SimulationSideEffectWarning>>defaultAction (in category 'priv handling') ----- + defaultAction + + self suppressed ifFalse: [super defaultAction]. + self flag: #forLater. "When we support explicit exception handler invocation (e.g., #resume, #retry) from the debugger, this exception should publish a #resume handler rather than relying on the weakly defined proceed semantics of the debugger." + ^ self defaultResumeValue!
Item was added: + ----- Method: SimulationSideEffectWarning>>defaultResumeValue (in category 'defaults') ----- + defaultResumeValue + + ^ true!
Item was added: + ----- Method: SimulationSideEffectWarning>>isControlPrimitive (in category 'testing') ----- + isControlPrimitive + "See StackInterpreter class>>#initializePrimitiveTable." + + ^ self primitive between: 80 and: 89!
Item was added: + ----- Method: SimulationSideEffectWarning>>isSimulationGuard (in category 'testing') ----- + isSimulationGuard + "See Parser >> #simulationGuard." + + ^ self primitive = 19!
Item was added: + ----- Method: SimulationSideEffectWarning>>messageText (in category 'printing') ----- + messageText + + ^ messageText ifNil: [ + 'The code being simulated is trying to control a process ({1}). {2}' translated format: { + self context method reference. + self isSimulationGuard + ifTrue: ['If you proceed, your image may be locked. 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]}]!
Item was added: + ----- Method: SimulationSideEffectWarning>>method (in category 'accessing') ----- + method + + ^ method!
Item was added: + ----- Method: SimulationSideEffectWarning>>primitive (in category 'accessing') ----- + primitive + + ^ primitiveIndex!
Item was added: + ----- Method: SimulationSideEffectWarning>>primitive: (in category 'initialize-release') ----- + primitive: anInteger + + primitiveIndex := anInteger.!
Item was added: + ----- Method: SimulationSideEffectWarning>>signalIfSkipped: (in category 'signaling') ----- + signalIfSkipped: skipBlock + + ^ self signal ifFalse: skipBlock!
Item was added: + ----- Method: SimulationSideEffectWarning>>skipPrimitive (in category 'handling') ----- + skipPrimitive + + ^ self resume: false!
Item was added: + ----- Method: SimulationSideEffectWarning>>suppress (in category 'accessing') ----- + suppress + + suppressed := true.!
Item was added: + ----- Method: SimulationSideEffectWarning>>suppressed (in category 'accessing') ----- + suppressed + + ^ suppressed ifNil: [self isSimulationGuard not]!
Item was added: + ----- Method: SimulationSideEffectWarning>>theReceiver (in category 'accessing') ----- + theReceiver + + ^ receiver!
Item was added: + ----- Method: SimulationSideEffectWarning>>unsuppress (in category 'accessing') ----- + unsuppress + + suppressed := false.!