Add Simulator framework (#27)

Simulator implements the Chain of Responsibility pattern to make multiple customizations to the simulation engine combinable. Additionally, SimulationMessageSendRecorder (8f12aff) and Sandbox (fddeb9a) are ported to this new framework (for Sandbox, the new version is called Sandbox2). Tests exist as well, of course.

Closes #15.

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/README.md

@@ -0,0 +1 @@
+I am a simulation context that delegates control to a Simulator. All delegators are implemented in my subclass SimulatorClass; however, for performance reasons, the simulator will only compile those delegators that it actually used into a private subclass of myself. See #requiredCapabilities.

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/class/forbiddenBasicAddSelector.withMethod..st

@@ -0,0 +1,5 @@
+template - accessing method dictionary
+forbiddenBasicAddSelector: selector withMethod: aCompiledMethod
+
+	"This message is sent to read-only context classes!"
+	^ NotImplemented signal: 'You shall not want to edit this uniclass itself. Instead, add the new method to SimulationContext or BasicSimulatorContext, or implement a capability/delegator on SimulatorContext and then restart the simulator.'

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/class/forbiddenBasicRemoveSelector..st

@@ -0,0 +1,5 @@
+template - accessing method dictionary
+forbiddenBasicRemoveSelector: selector
+
+	"This message is sent to read-only context classes!"
+	^ NotImplemented signal: 'You shall not want to edit this uniclass itself. Instead, remove the undesired capability from your simulator and restart all running instances.'

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/class/newFor..st

@@ -0,0 +1,6 @@
+instance creation
+newFor: aSimulator
+
+	^ self new
+		simulator: aSimulator;
+		yourself

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/instance/initializeFrom..st

@@ -0,0 +1,6 @@
+initialize-release
+initializeFrom: anotherContext
+
+	super initializeFrom: anotherContext.
+
+	simulator := anotherContext simulator.

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/instance/simulator..st

@@ -0,0 +1,4 @@
+accessing
+simulator: aSimulator
+
+	simulator := aSimulator

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/instance/simulator.st

@@ -0,0 +1,4 @@
+accessing
+simulator
+
+	^ simulator

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/methodProperties.json

@@ -0,0 +1,9 @@
+{
+	"class" : {
+		"forbiddenBasicAddSelector:withMethod:" : "ct 11/13/2021 20:07",
+		"forbiddenBasicRemoveSelector:" : "ct 11/13/2021 20:14",
+		"newFor:" : "ct 11/11/2021 21:16" },
+	"instance" : {
+		"initializeFrom:" : "ct 11/11/2021 21:14",
+		"simulator" : "ct 11/11/2021 21:14",
+		"simulator:" : "ct 11/11/2021 21:17" } }

packages/SimulationStudio-Base.package/BasicSimulatorContext.class/properties.json

@@ -0,0 +1,14 @@
+{
+	"category" : "SimulationStudio-Base",
+	"classinstvars" : [
+		 ],
+	"classvars" : [
+		 ],
+	"commentStamp" : "ct 11/13/2021 16:29",
+	"instvars" : [
+		"simulator" ],
+	"name" : "BasicSimulatorContext",
+	"pools" : [
+		 ],
+	"super" : "SimulationContext",
+	"type" : "variable" }

packages/SimulationStudio-Base.package/SimulationContext.class/instance/activateMethod.withArgs.receiver..st

@@ -0,0 +1,4 @@
+as yet unclassified
+activateMethod: newMethod withArgs: args receiver: rcvr
+
+	^ self customize: (super activateMethod: newMethod withArgs: args receiver: rcvr)

packages/SimulationStudio-Base.package/SimulationContext.class/instance/activateReturn.value..st

@@ -0,0 +1,4 @@
+as yet unclassified
+activateReturn: aContext value: value
+
+	^ self customize: (super activateReturn: aContext value: value)

packages/SimulationStudio-Base.package/SimulationContext.class/instance/step.st

@@ -1,4 +1,5 @@
 system simulation
 step
 
+	self flag: #todo. "This is our last resort only - preferably, we should identify all places where new contexts are generated (e.g., during block activation) and convert them there already!"
 	^ self customize: super step

packages/SimulationStudio-Base.package/SimulationContext.class/methodProperties.json

@@ -11,6 +11,8 @@
 		"runSimulated:" : "ct 12/28/2020 15:05",
 		"runSimulated:contextAtEachStep:" : "ct 12/28/2020 16:39" },
 	"instance" : {
+		"activateMethod:withArgs:receiver:" : "ct 11/12/2021 21:05",
+		"activateReturn:value:" : "ct 11/12/2021 21:05",
 		"at:" : "ct 12/28/2020 19:14",
 		"at:put:" : "ct 12/28/2020 19:14",
 		"basicAt:" : "ct 12/28/2020 19:14",
@@ -34,5 +36,5 @@
 		"shouldNotImplement:" : "ct 12/28/2020 15:29",
 		"size" : "ct 12/28/2020 19:14",
 		"stackp:" : "ct 12/28/2020 19:13",
-		"step" : "ct 3/14/2021 15:21",
+		"step" : "ct 11/13/2021 19:45",
 		"tryNamedPrimitiveIn:for:withArgs:" : "ct 3/6/2021 12:18" } }

packages/SimulationStudio-Base.package/Simulator.class/README.md

@@ -0,0 +1,5 @@
+I am an execution engine for Smalltalk code that is fully customizable by subclasses. Internally, I maintan all stack frames as subinstances of the class BasicSimulatorContext. For performance reasons, the exact stack frame class is determined dynamically based on the capabilities that my instances overwrite. See #requiredCapabilities and the #capability: pragma.
+
+I implement the Chain of Responsibility pattern, allowing clients to combine multiple simulators at their discretion. To chain multiple simulators, send #decorating: or #nextSimulator:. To not break the Chain of Responsibility, subclasses should usually send super when overriding any hook.
+
+I also provide support for the debugger - send #debug: to watch the simulated code in a normal Squeak Debugger.

packages/SimulationStudio-Base.package/Simulator.class/class/basicContextClass.st

@@ -0,0 +1,4 @@
+context classes
+basicContextClass
+
+	^ BasicSimulatorContext

packages/SimulationStudio-Base.package/Simulator.class/class/cleanUp.st

@@ -0,0 +1,4 @@
+initialize-release
+cleanUp
+
+	self cleanUpContextClasses.

packages/SimulationStudio-Base.package/Simulator.class/class/cleanUpContextClasses.st

@@ -0,0 +1,6 @@
+context classes
+cleanUpContextClasses
+
+	ContextClasses ifNil: [^ self].
+	ContextClasses do: [:class | class removeFromSystem].
+	ContextClasses := nil.

packages/SimulationStudio-Base.package/Simulator.class/class/contextClassForCapabilities..st

@@ -0,0 +1,22 @@
+context classes
+contextClassForCapabilities: capabilities
+
+	(capabilities isKindOf: Set) ifFalse: [^ self contextClassForCapabilities: capabilities asSet].
+
+	self flag: #todo. "ContextClasses are never cleaned up automatically! Should we use weak data structure and pin capabilities array in simulator?"
+
+	^ (ContextClasses ifNil: [ContextClasses := Dictionary new])
+		at: capabilities
+		ifAbsentPut: [ | class |
+			class := self basicContextClass newSubclass.
+			capabilities do: [:selector |
+				class
+					addSelectorSilently: selector
+					withMethod: (self fullContextClass >> selector) copy].
+			"Seal class to avoid developer confusion."
+			class theMetaClass
+				addSelectorSilently: #basicAddSelector:withMethod:
+					withMethod: (class theMetaClass lookupSelector: #forbiddenBasicAddSelector:withMethod:) copy;
+				addSelectorSilently: #basicRemoveSelector:
+					withMethod: (class theMetaClass lookupSelector: #forbiddenBasicRemoveSelector:) copy.
+			class]

packages/SimulationStudio-Base.package/Simulator.class/class/contextClassForSimulators..st

@@ -0,0 +1,8 @@
+context classes
+contextClassForSimulators: simulatorArray
+
+	| requiredCapabilities |
+	requiredCapabilities := (simulatorArray gather: [:simulator | simulator requiredCapabilities
+		ifNil: [^ self fullContextClass]]) as: Set.
+
+	^ self contextClassForCapabilities: requiredCapabilities

packages/SimulationStudio-Base.package/Simulator.class/class/debug..st

@@ -0,0 +1,4 @@
+support
+debug: aBlock
+
+	^ self new debug: aBlock

packages/SimulationStudio-Base.package/Simulator.class/class/decorating..st

@@ -0,0 +1,6 @@
+instance creation
+decorating: aSimulator
+
+	^ self new
+		nextSimulator: aSimulator;
+		yourself

packages/SimulationStudio-Base.package/Simulator.class/class/evaluate..st

@@ -0,0 +1,4 @@
+evaluating
+evaluate: aBlock
+
+	^ self new evaluate: aBlock

packages/SimulationStudio-Base.package/Simulator.class/class/fullContextClass.st

@@ -0,0 +1,4 @@
+context classes
+fullContextClass
+
+	^ SimulatorContext

packages/SimulationStudio-Base.package/Simulator.class/class/noteAddedSelector.meta..st

@@ -0,0 +1,8 @@
+accessing method dictionary
+noteAddedSelector: selector meta: isMeta
+
+	super noteAddedSelector: selector meta: isMeta.
+
+	self flag: #todo. "Is this the right hook? There is also #noteCompilationOf:meta: ..."
+	self allSubInstances ifNotEmpty: [
+		Transcript showln: ('You should restart all {1} subinstances now to apply the changes to {2}.' format: {self. selector})].

packages/SimulationStudio-Base.package/Simulator.class/class/warmUp.st

@@ -0,0 +1,4 @@
+initialize-release
+warmUp
+
+	self warmUpContextClasses.

packages/SimulationStudio-Base.package/Simulator.class/class/warmUpContextClasses.st

@@ -0,0 +1,5 @@
+context classes
+warmUpContextClasses
+
+	self withAllSubclassesDo: [:class |
+		self contextClassForSimulators: {class basicNew}].

packages/SimulationStudio-Base.package/Simulator.class/instance/basicSimulate.do..st

@@ -0,0 +1,10 @@
+private
+basicSimulate: aBlock do: contextClassBlock
+	"DO NOT override this! To wrap custom logic around the simulated code, override #basicSimulate:do:chain: instead."
+
+	^ self
+		basicSimulate: aBlock
+		do: [:theBlock :simulatorArray | | contextClass |
+			contextClass := self class contextClassForSimulators: simulatorArray.
+			contextClassBlock value: contextClass value: simulatorArray first value: theBlock]
+		chain: {self}

packages/SimulationStudio-Base.package/Simulator.class/instance/basicSimulate.do.chain..st

@@ -0,0 +1,8 @@
+private
+basicSimulate: simulatedBlock do: simulatorBlock chain: simulatorArray
+	"Hook for subclasses which should decorate their logic around a super send to this method."
+
+	nextSimulator ifNotNil: [
+		^ nextSimulator basicSimulate: simulatedBlock do: simulatorBlock chain: (simulatorArray copyWith: nextSimulator)].
+
+	^ simulatorBlock value: simulatedBlock value: simulatorArray

packages/SimulationStudio-Base.package/Simulator.class/instance/context.activateMethod.withArgs.receiver.do..st

@@ -0,0 +1,7 @@
+controlling
+context: aContext activateMethod: aCompiledMethod withArgs: arguments receiver: receiver do: aBlock
+	<capability: #activateMethod:withArgs:receiver:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext activateMethod: aCompiledMethod withArgs: arguments receiver: receiver do: aBlock]
+		ifNil: [aBlock value: aCompiledMethod value: arguments value: receiver]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.blockReturnConstant.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext blockReturnConstant: value do: aBlock
+	<capability: #blockReturnConstant:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext blockReturnConstant: value do: aBlock]
+		ifNil: [aBlock value: value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.callPrimitive.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext callPrimitive: primNumber do: aBlock
+	<capability: #callPrimitive:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext callPrimitive: primNumber do: aBlock]
+		ifNil: [aBlock value: primNumber]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.directedSuperSend.numArgs.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext directedSuperSend: selector numArgs: numArgs do: aBlock
+	<capability: #directedSuperSend:numArgs:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext directedSuperSend: selector numArgs: numArgs do: aBlock]
+		ifNil: [aBlock value: selector value: numArgs]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doBlockReturnTop..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext doBlockReturnTop: aBlock
+	<capability: #blockReturnTop>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doBlockReturnTop: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doDup..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext doDup: aBlock
+	<capability: #doDup>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doDup: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doMethodReturnReceiver..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext doMethodReturnReceiver: aBlock
+	<capability: #methodReturnReceiver>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doMethodReturnReceiver: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doMethodReturnTop..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext doMethodReturnTop: aBlock
+	<capability: #methodReturnTop>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doMethodReturnTop: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doPop..st

@@ -0,0 +1,7 @@
+controlling
+context: aContext doPop: aBlock
+	<capability: #pop>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doPop: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doPrimitive.method.receiver.args.do..st

@@ -0,0 +1,7 @@
+controlling
+context: aContext doPrimitive: primitiveIndex method: aCompiledMethod receiver: receiver args: arguments do: aBlock
+	<capability: #doPrimitive:method:receiver:args:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doPrimitive: primitiveIndex method: aCompiledMethod receiver: receiver args: arguments do: aBlock]
+		ifNil: [aBlock value: primitiveIndex value: aCompiledMethod value: receiver value: arguments]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doPushActiveContext..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext doPushActiveContext: aBlock
+	<capability: #pushActiveContext>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doPushActiveContext: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.doPushReceiver..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext doPushReceiver: aBlock
+	<capability: #pushReceiver>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext doPushReceiver: aBlock]
+		ifNil: [aBlock value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.jump.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext jump: distance do: aBlock
+	<capability: #jump:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext jump: distance do: aBlock]
+		ifNil: [aBlock value: distance]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.jump.if.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext jump: distance if: condition do: aBlock
+	<capability: #jump:if:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext jump: distance if: condition do: aBlock]
+		ifNil: [aBlock value: distance value: condition]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.methodReturnConstant.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext methodReturnConstant: value do: aBlock
+	<capability: #methodReturnConstant:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext methodReturnConstant: value do: aBlock]
+		ifNil: [aBlock value: value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.popIntoLiteralVariable.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext popIntoLiteralVariable: value do: aBlock
+	<capability: #popIntoLiteralVariable:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext popIntoLiteralVariable: value do: aBlock]
+		ifNil: [aBlock value: value]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.popIntoReceiverVariable.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext popIntoReceiverVariable: offset do: aBlock
+	<capability: #popIntoReceiverVariable:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext popIntoReceiverVariable: offset do: aBlock]
+		ifNil: [aBlock value: offset]

packages/SimulationStudio-Base.package/Simulator.class/instance/context.popIntoRemoteTemp.inVectorAt.do..st

@@ -0,0 +1,7 @@
+instruction processing
+context: aContext popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex do: aBlock
+	<capability: #popIntoRemoteTemp:inVectorAt:>
+
+	^ nextSimulator
+		ifNotNil: [nextSimulator context: aContext popIntoRemoteTemp: remoteTempIndex inVectorAt: tempVectorIndex do: aBlock]
+		ifNil: [aBlock value: remoteTempIndex value: tempVectorIndex]