VM Maker: VMMaker.oscog-eem.2851.mcz

 
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.2851.mcz

==================== Summary ====================

Name: VMMaker.oscog-eem.2851
Author: eem
Time: 23 October 2020, 2:40:48.096696 pm
UUID: e46fa7ed-5535-4332-8d36-764329448a33
Ancestors: VMMaker.oscog-eem.2850

CoInterpreterMT: eliminate use of reenterInterpreter, thsi is StackInterpreter only now.

FilePlugin: use methodReturnInteger: rather than methodReturnValue: ... intergerObjectOf::

Simulators: start to simulate the interrupt-driven inputSemaphore input event mechanism (with an egregious hack in ioRelinquishProcessorForMicroseconds: that we can probably get rid of when we understand the code better).  The mystery is that the changes here do allow events to get in quickly (e.g. Run tests in a TestRunner) but the screen menu resolutely refuses to appear (?!?!).  Move ioGetNextEvent:, queueForwardedEvent: & ioProcessEvents up into StackInterpreter (as doNotGenerate).  Use DoubleWordArray for the input event buffer on 64-bits.

=============== Diff against VMMaker.oscog-eem.2850 ===============

Item was changed:
  ----- Method: CoInterpreterMT>>enterSmalltalkExecutiveImplementation (in category 'initialization') -----
  enterSmalltalkExecutiveImplementation
  "Main entry-point into the interpreter at each execution level, where an execution
  level is either the start of execution or reentry for a callback.  Capture the C stack
  pointers so that calls from machine-code into the C run-time occur at this level.
  This is the actual implementation, separated from enterSmalltalkExecutive so the
  simulator can wrap it in an exception handler and hence simulate the setjmp/longjmp.
 
  Override to return if a longjmp to reenterInterpreter passes a parameter greater than 1.
  This causes a return to threadSchedulingLoop:startingVM: and is used to surrender
  control to another thread."
  <inline: false>
  self assertSaneThreadAndProcess.
+ ^super enterSmalltalkExecutiveImplementation!
- cogit assertCStackWellAligned.
- cogit ceCaptureCStackPointers.
- "Setjmp for reentry into interpreter from elsewhere, e.g. machine-code trampolines."
- (self _setjmp: reenterInterpreter) > 1 ifTrue:
- [^0].
- (self isMachineCodeFrame: framePointer) ifTrue:
- [self returnToExecutive: false postContextSwitch: true
- "NOTREACHED"].
- self setMethod: (self iframeMethod: framePointer).
- instructionPointer = cogit ceReturnToInterpreterPC ifTrue:
- [instructionPointer := self iframeSavedIP: framePointer].
- self assertValidExecutionPointe: instructionPointer r: framePointer s: stackPointer imbar: true line: #'__LINE__'.
- self interpret.
- "NOTREACHED"
- ^0!

Item was changed:
  ----- Method: CoInterpreterMT>>ownVM: (in category 'vm scheduling') -----
  ownVM: threadIndexAndFlags
  <api>
  <inline: false>
  "This is the entry-point for plugins and primitives that wish to reacquire the VM after having
  released it via disownVM or callbacks that want to acquire it without knowing their ownership
  status.  This call will block until the VM is owned by the current thread or an error occurs.
  The argument should be the value answered by disownVM, or 0 for callbacks that don't know
  if they have disowned or not.  This is both an optimization to avoid having to query thread-
  local storage for the current thread's index (since it can easily keep it in some local variable),
  and a record of when an unbound process becomes affined to a thread for the dynamic
  extent of some operation.
 
  Answer 0 if the current thread is known to the VM.
  Answer 1 if the current thread is unknown to the VM and takes ownership.
  Answer -1 if the current thread is unknown to the VM and fails to take ownership."
  | threadIndex flags vmThread myProc activeProc sched |
  <var: #vmThread type: #'CogVMThread *'>
  threadIndexAndFlags = 0 ifTrue:
  [^self ownVMFromUnidentifiedThread].
  threadIndex := threadIndexAndFlags bitAnd: ThreadIdMask.
  flags := threadIndexAndFlags >> DisownFlagsShift.
  (flags anyMask: DisownVMForProcessorRelinquish) ifTrue:
  [relinquishing := false.
  self sqLowLevelMFence].
  (threadIndexAndFlags anyMask: LockGUIThreadFlag) ifTrue:
  [self assert: (noThreadingOfGUIThread and: [self inGUIThread]).
  self assert: disowningVMThread = nil.
  (flags anyMask: DisownVMLockOutFullGC) ifTrue:
  [objectMemory decrementFullGCLock].
  cogit recordEventTrace ifTrue:
  [self recordTrace: TraceOwnVM thing: ConstZero source: 0].
  ^0].
 
  vmThread := cogThreadManager acquireVMFor: threadIndex.
  disownCount := disownCount - 1.
 
  (flags anyMask: DisownVMLockOutFullGC) ifTrue:
  [objectMemory decrementFullGCLock].
  disowningVMThread notNil ifTrue:
  [vmThread = disowningVMThread ifTrue:
  [self cCode: ''
  inSmalltalk:
  [| range |
  range := self cStackRangeForThreadIndex: threadIndex.
  self assert: (range includes: CStackPointer).
  self assert: (range includes: CFramePointer)].
  self assert: self successful.
  self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject.
  disowningVMThread := nil.
  cogit recordEventTrace ifTrue:
  [self recordTrace: TraceOwnVM thing: ConstOne source: 0].
  ^0].  "if not preempted we're done."
  self preemptDisowningThread].
  "We've been preempted; we must restore state and update the threadId
  in our process, and may have to put the active process to sleep."
  sched := self schedulerPointer.
  activeProc := objectMemory fetchPointer: ActiveProcessIndex ofObject: sched.
  (threadIndexAndFlags anyMask: OwnVMForeignThreadFlag)
  ifTrue:
  [self assert: foreignCallbackProcessSlot == ForeignCallbackProcess.
  myProc := objectMemory splObj: foreignCallbackProcessSlot.
  self assert: myProc ~= objectMemory nilObject.
  objectMemory splObj: foreignCallbackProcessSlot put: objectMemory nilObject]
  ifFalse: [myProc := cogThreadManager popAWOLProcess: vmThread].
  self assert: activeProc ~= myProc.
  (activeProc ~= objectMemory nilObject
  and: [(objectMemory fetchPointer: MyListIndex ofObject: activeProc) = objectMemory nilObject]) ifTrue:
  [self putToSleep: activeProc yieldingIf: preemptionYields].
  self assert: (objectMemory fetchPointer: MyListIndex ofObject: myProc) = (objectMemory splObj: ProcessInExternalCodeTag).
  objectMemory
  storePointer: ActiveProcessIndex ofObject: sched withValue: myProc;
  storePointerUnchecked: MyListIndex ofObject: myProc withValue: objectMemory nilObject.
  "Only unaffine if the process was affined at this level and did not become bound in the interim."
  ((threadIndexAndFlags anyMask: ProcessUnaffinedOnDisown)
  and: [(self isBoundProcess: myProc) not]) ifTrue:
  [self setOwnerIndexOfProcess: myProc to: 0 bind: false].
  self initPrimCall.
  self externalSetStackPageAndPointersForSuspendedContextOfProcess: myProc.
  "If this primitive is called from machine code maintain the invariant that the return pc
  of an interpreter callee calling a machine code caller is ceReturnToInterpreterPC."
  (vmThread inMachineCode
  and: [instructionPointer >= objectMemory startOfMemory]) ifTrue:
  [self iframeSavedIP: framePointer put: instructionPointer.
  instructionPointer := cogit ceReturnToInterpreterPC].
  newMethod := vmThread newMethodOrNull.
  argumentCount := vmThread argumentCount.
- self cCode:
- [self memcpy: reenterInterpreter
- _: vmThread reenterInterpreter
- _: (self sizeof: #'jmp_buf')]
- inSmalltalk:
- [reenterInterpreter := vmThread reenterInterpreter].
  vmThread newMethodOrNull: nil.
  self cCode: ''
  inSmalltalk:
  [| range |
  range := self cStackRangeForThreadIndex: threadIndex.
  self assert: (range includes: vmThread cStackPointer).
  self assert: (range includes: vmThread cFramePointer)].
  self setCFramePointer: vmThread cFramePointer setCStackPointer: vmThread cStackPointer.
  self assert: newMethod ~~ nil.
  cogit recordEventTrace ifTrue:
  [self recordTrace: TraceOwnVM thing: ConstTwo source: 0].
  ^threadIndexAndFlags bitAnd: OwnVMForeignThreadFlag!

Item was changed:
  ----- Method: CoInterpreterMT>>preemptDisowningThread (in category 'vm scheduling') -----
  preemptDisowningThread
  "Set the relevant state for disowningVMThread so that it can resume after
  being preempted and set disowningVMThread to nil to indicate preemption.
 
  N.B.  This should only be sent from checkPreemptionOfDisowningThread.
 
  There are essentially four things to do.
  a) save the VM's notion of the current C stack pointers; these are pointers
  into a thread's stack and must be saved and restored in thread switch.
  b) save the VM's notion of the current Smalltalk execution point.  This is
  simply the suspend half of a process switch that saves the current context
  in the current process.
  c) add the process to the thread's set of AWOL processes so that the scheduler
  won't try to run the process while the thread has disowned the VM.
  d) save the in-primitive VM state, newMethod and argumentCount
 
  ownVM: will restore the VM context as of disownVM: from the above when it
  finds it has been preempted."
 
  | activeProc activeContext preemptedThread |
  <var: #preemptedThread type: #'CogVMThread *'>
  <inline: false>
  self assert: disowningVMThread notNil.
  self assert: (disowningVMThread state = CTMUnavailable
  or: [disowningVMThread state = CTMWantingOwnership]).
  self cCode: ''
  inSmalltalk:
  [| range |
  range := self cStackRangeForThreadIndex: disowningVMThread index.
  self assert: (range includes: CStackPointer).
  self assert: (range includes: CFramePointer)].
  cogit recordEventTrace ifTrue:
  [self recordTrace: TracePreemptDisowningThread
  thing: (objectMemory integerObjectOf: disowningVMThread index)
  source: 0].
  disowningVMThread cStackPointer: CStackPointer.
  disowningVMThread cFramePointer: CFramePointer.
  activeProc := self activeProcess.
  self assert: (objectMemory fetchPointer: MyListIndex ofObject: activeProc) = objectMemory nilObject.
  objectMemory
  storePointer: MyListIndex
  ofObject: activeProc
  withValue: (objectMemory splObj: ProcessInExternalCodeTag).
  "The instructionPointer must be pushed because the convention for inactive stack pages is that the
  instructionPointer is top of stack.  We need to know if this primitive is called from machine code
  because the invariant that the return pc of an interpreter callee calling a machine code caller is
  ceReturnToInterpreterPC must be maintained."
  self push: instructionPointer.
  self externalWriteBackHeadFramePointers.
  activeContext := self ensureFrameIsMarried: framePointer SP: stackPointer.
  objectMemory
  storePointer: SuspendedContextIndex
  ofObject: activeProc
  withValue: activeContext.
  "Since pushing the awol process may realloc disowningVMThread we need to reassign.
  But since we're going to nil disowningVMThread anyway we can assign to a local."
  preemptedThread := cogThreadManager pushAWOLProcess: activeProc on: disowningVMThread.
  disowningVMThread := nil.
  preemptedThread priority: (self quickFetchInteger: PriorityIndex ofObject: activeProc).
  (self ownerIndexOfProcess: activeProc) = 0
  ifTrue: [self setOwnerIndexOfProcess: activeProc to: preemptedThread index bind: false]
  ifFalse: [self assert: (self ownerIndexOfProcess: activeProc) = preemptedThread index].
  preemptedThread
  newMethodOrNull: newMethod;
  argumentCount: argumentCount;
+ inMachineCode: instructionPointer asUnsignedInteger <= objectMemory startOfMemory!
- inMachineCode: instructionPointer asUnsignedInteger <= objectMemory startOfMemory.
- self cCode:
- [self memcpy: preemptedThread reenterInterpreter
- _: reenterInterpreter
- _: (self sizeof: #'jmp_buf')]
- inSmalltalk:
- [preemptedThread reenterInterpreter: reenterInterpreter]!

Item was changed:
  ----- Method: CoInterpreterMT>>primitiveRelinquishProcessor (in category 'I/O primitives') -----
  primitiveRelinquishProcessor
  "Relinquish the processor for up to the given number of microseconds.
  The exact behavior of this primitive is platform dependent.
  Override to check for waiting threads."
 
+ | microSecs threadIndexAndFlags currentCStackPointer currentCFramePointer |
- | microSecs threadIndexAndFlags currentCStackPointer currentCFramePointer savedReenterInterpreter |
  <var: #currentCStackPointer type: #'void *'>
  <var: #currentCFramePointer type: #'void *'>
  <var: #savedReenterInterpreter type: #'jmp_buf'>
  microSecs := self stackTop.
  (objectMemory isIntegerObject: microSecs) ifFalse:
  [^self primitiveFail].
  self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject.
  self assert: relinquishing not.
  "DO NOT allow relinquishing the processor while we are profiling since this
  may skew the time base for our measures (it may reduce processor speed etc).
  Instead we go full speed, therefore measuring the precise time we spend in the
  inner idle loop as a busy loop."
  nextProfileTick = 0 ifTrue:
  "Presumably we have nothing to do; this primitive is typically called from the
  background process. So we should /not/ try and activate any threads in the
  pool; they will waste cycles finding there is no runnable process, and will
  cause a VM abort if no runnable process is found.  But we /do/ want to allow
  FFI calls that have completed, or callbacks a chance to get into the VM; they
  do have something to do.  DisownVMForProcessorRelinquish indicates this."
  [currentCStackPointer := CStackPointer.
  currentCFramePointer := CFramePointer.
- self cCode:
- [self memcpy: savedReenterInterpreter asVoidPointer
- _: reenterInterpreter
- _: (self sizeof: #'jmp_buf')].
  threadIndexAndFlags := self disownVM: DisownVMForProcessorRelinquish.
  self assert: relinquishing.
  self ioRelinquishProcessorForMicroseconds: (objectMemory integerValueOf: microSecs).
  self assert: relinquishing.
  self ownVM: threadIndexAndFlags.
  self assert: relinquishing not.
  self assert: cogThreadManager currentVMThread state = CTMAssignableOrInVM.
  self assert: currentCStackPointer = CStackPointer.
  self assert: currentCFramePointer = CFramePointer.
+ "In simulation we allow ioRelinquishProcessorForMicroseconds: to fail so that
+  we can arrange that the simulator responds to input events promply.  This
+  *DOES NOT HAPPEN* in the real vm."
+ self cCode: [] inSmalltalk: [primFailCode ~= 0 ifTrue: [^self]]].
- self cCode:
- [self assert: (self mem: (self cCoerceSimple: savedReenterInterpreter to: #'void *')
- cm: reenterInterpreter
- p: (self sizeof: #'jmp_buf')) = 0]].
  self assert: (objectMemory fetchPointer: MyListIndex ofObject: self activeProcess) = objectMemory nilObject.
  self pop: 1  "microSecs; leave rcvr on stack"!

Item was changed:
  ----- Method: CoInterpreterMT>>returnToSchedulingLoopAndReleaseVMOrWakeThread:source: (in category 'process primitive support') -----
  returnToSchedulingLoopAndReleaseVMOrWakeThread: vmThread source: source
- | savedReenterInterpreter |
- <var: #savedReenterInterpreter type: #'jmp_buf'>
  <var: #vmThread type: #'CogVMThread *'>
  <inline: false>
  self cCode:
  [self flag: 'this is just for debugging.  Note the current C stack pointers'.
  cogThreadManager currentVMThread
  cStackPointer: CStackPointer;
  cFramePointer: CFramePointer]
  inSmalltalk:
  [| range |
  range := self cStackRangeForThreadIndex: cogThreadManager getVMOwner.
  self assert: (range includes: CStackPointer).
  self assert: (range includes: CFramePointer)].
- "We must use a copy of reenterInterpreter since we're giving up the VM to another vmThread."
- self cCode:
- [self memcpy: savedReenterInterpreter asVoidPointer
- _: reenterInterpreter
- _: (self sizeof: #'jmp_buf')]
- inSmalltalk:
- [savedReenterInterpreter := reenterInterpreter].
  self recordThreadSwitchTo: (vmThread ifNotNil: [vmThread index] ifNil: [0]) source: source.
  vmThread
  ifNotNil: [cogThreadManager wakeVMThreadFor: vmThread index]
  ifNil: [cogThreadManager releaseVM].
  "2 implies returning to the threadSchedulingLoop."
+ self shouldBeImplemented.
+ "was: self _longjmp: savedReenterInterpreter _: ReturnToThreadSchedulingLoop.
+ But now we have ceInvokeInterpret, not reenterInterpreter, so we have to fugure out a new way in..."!
- self _longjmp: savedReenterInterpreter _: ReturnToThreadSchedulingLoop!

Item was changed:
  CoInterpreterMT subclass: #CogVMSimulator
+ instanceVariableNames: 'parent enableCog byteCount lastPollCount lastExtPC sendCount lookupCount printSends traceOn myBitBlt displayForm fakeForm imageName pluginList mappedPluginEntries quitBlock transcript displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes uniqueIndices uniqueIndex breakCount atEachStepBlock startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize debugStackDepthDictionary performFilters eventQueue effectiveCogCodeSize expectedSends expecting inputSemaphoreIndex'
- instanceVariableNames: 'parent enableCog byteCount lastPollCount lastExtPC sendCount lookupCount printSends traceOn myBitBlt displayForm fakeForm imageName pluginList mappedPluginEntries quitBlock transcript displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes uniqueIndices uniqueIndex breakCount atEachStepBlock startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize debugStackDepthDictionary performFilters eventQueue effectiveCogCodeSize expectedSends expecting'
  classVariableNames: 'ByteCountsPerMicrosecond ExpectedSends NLRFailures NLRSuccesses StackAlteringPrimitives'
  poolDictionaries: ''
  category: 'VMMaker-JITSimulation'!
 
  !CogVMSimulator commentStamp: 'eem 9/3/2013 11:16' prior: 0!
  This class defines basic memory access and primitive simulation so that the CoInterpreter can run simulated in the Squeak environment.  It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.  Remember that you can test the Cogit using its class-side in-image compilation facilities.
 
  To see the thing actually run, you could (after backing up this image and changes), execute
 
  (CogVMSimulator new openOn: Smalltalk imageName) test
 
  and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be.  We usually do this with a small and simple benchmark image.
 
  Here's an example to launch the simulator in a window.  The bottom-right window has a menu packed with useful stuff:
 
  (CogVMSimulator newWithOptions: #(Cogit StackToRegisterMappingCogit))
  desiredNumStackPages: 8;
  openOn: '/Users/eliot/Cog/startreader.image';
  openAsMorph;
  run
 
  Here's a hairier example that I (Eliot) actually use in daily development with some of the breakpoint facilities commented out.
 
  | cos proc opts |
  CoInterpreter initializeWithOptions: (opts := Dictionary newFromPairs: #(Cogit StackToRegisterMappingCogit)).
  CogVMSimulator chooseAndInitCogitClassWithOpts: opts.
  cos := CogVMSimulator new.
  "cos initializeThreadSupport." "to test the multi-threaded VM"
  cos desiredNumStackPages: 8. "to set the size of the stack zone"
  "cos desiredCogCodeSize: 8 * 1024 * 1024." "to set the size of the Cogit's code zone"
  cos openOn: '/Users/eliot/Squeak/Squeak4.4/trunk44.image'. "choose your favourite image"
  "cos setBreakSelector: 'r:degrees:'." "set a breakpoint at a specific selector"
  proc := cos cogit processor.
  "cos cogit sendTrace: 7." "turn on tracing"
  "set a complex breakpoint at a specific point in machine code"
  "cos cogit singleStep: true; breakPC: 16r56af; breakBlock: [:cg|  cos framePointer > 16r101F3C and: [(cos longAt: cos framePointer - 4) = 16r2479A and: [(cos longAt: 16r101F30) = (cos longAt: 16r101F3C) or: [(cos longAt: 16r101F2C) = (cos longAt: 16r101F3C)]]]]; sendTrace: 1".
  "[cos cogit compilationTrace: -1] on: MessageNotUnderstood do: [:ex|]." "turn on compilation tracing in the StackToRegisterMappingCogit"
  "cos cogit setBreakMethod: 16rB38880."
  cos
  openAsMorph;
  "toggleTranscript;" "toggleTranscript will send output to the Transcript instead of the morph's rather small window"
  halt;
  run!

Item was changed:
  ----- Method: CogVMSimulator>>initialize (in category 'initialization') -----
  initialize
  "Initialize the CogVMSimulator when running the interpreter inside Smalltalk.  The
  primary responsibility of this method is to allocate Smalltalk Arrays for variables
  that will be declared as statically-allocated global arrays in the translated code."
  super initialize.
 
  transcript := Transcript.
 
  objectMemory ifNil:
  [objectMemory := self class objectMemoryClass simulatorClass new].
  cogit ifNil:
  [cogit := self class cogitClass new setInterpreter: self].
  objectMemory coInterpreter: self cogit: cogit.
 
  (cogit numRegArgs > 0
  and: [VMClass initializationOptions at: #CheckStackDepth ifAbsent: [true]]) ifTrue:
  [debugStackDepthDictionary := Dictionary new].
 
  cogThreadManager ifNotNil:
  [super initialize].
 
  self assert: ConstMinusOne = (objectMemory integerObjectOf: -1).
 
  cogMethodZone := cogit methodZone. "Because Slang can't remove intermediate implicit receivers (cogit methodZone foo doesn't reduce to foo())"
  enableCog := true.
 
  methodCache := Array new: MethodCacheSize.
  nsMethodCache := Array new: NSMethodCacheSize.
  atCache := nil.
  self flushMethodCache.
  cogCompiledCodeCompactionCalledFor := false.
  gcSemaphoreIndex := 0.
  externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
  externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
  externalPrimitiveTableFirstFreeIndex := 0.
  primitiveTable := self class primitiveTable copy.
  self initializePluginEntries.
  desiredNumStackPages := InitializationOptions at: #desiredNumStackPages ifAbsent: [0].
  desiredEdenBytes := InitializationOptions at: #desiredEdenBytes ifAbsent: [0].
  desiredCogCodeSize  := InitializationOptions at: #desiredCogCodeSize ifAbsent: [0].
  "This is initialized on loading the image, but convenient for testing stack page values..."
  numStackPages := self defaultNumStackPages.
  startMicroseconds := lastYieldMicroseconds := self ioUTCStartMicroseconds.
  maxLiteralCountForCompile := MaxLiteralCountForCompile.
  minBackwardJumpCountForCompile := MinBackwardJumpCountForCompile.
  flagInterpretedMethods := false.
 
  "initialize InterpreterSimulator variables used for debugging"
  byteCount := lastPollCount := sendCount := lookupCount := 0.
  quitBlock := [^self close].
  traceOn := true.
  printSends := printFrameAtEachStep := printBytecodeAtEachStep := false.
  myBitBlt := BitBltSimulator new setInterpreter: self.
  displayForm := fakeForm := 'Display has not yet been installed' asDisplayText form.
- eventQueue := SharedQueue new.
  suppressHeartbeatFlag := deferSmash := deferredSmash := false.
  systemAttributes := Dictionary new.
  primTraceLog := CArrayAccessor on: (Array new: 256 withAll: 0).
  primTraceLogIndex := 0.
  traceLog := CArrayAccessor on: (Array new: TraceBufferSize withAll: 0).
  traceLogIndex := 0.
  traceSources := TraceSources.
  statCodeCompactionCount := 0.
  statCodeCompactionUsecs := 0.
  extSemTabSize := 256!

Item was added:
+ ----- Method: CogVMSimulator>>inputSemaphoreIndex (in category 'I/O primitive support') -----
+ inputSemaphoreIndex
+ ^inputSemaphoreIndex!

Item was removed:
- ----- Method: CogVMSimulator>>ioGetNextEvent: (in category 'I/O primitives') -----
- ioGetNextEvent: evtBuf
- | evt |
- "SimulatorMorphicModel browse"
- eventQueue ifNil:
- [^self primitiveFail].
- eventQueue isEmpty ifFalse:
- [evt :=  eventQueue next.
- 1 to: evt size do:
- [:i|
- (evt at: i) ifNotNil:
- [:val|
- evtBuf
- at: i - 1
- put: (i = 2 ifTrue: [val bitAnd: MillisecondClockMask] ifFalse: [val])]]]!

Item was removed:
- ----- Method: CogVMSimulator>>ioProcessEvents (in category 'I/O primitives') -----
- ioProcessEvents!

Item was changed:
  ----- Method: CogVMSimulator>>ioRelinquishProcessorForMicroseconds: (in category 'I/O primitives support') -----
  ioRelinquishProcessorForMicroseconds: microseconds
  "In the simulator give an indication that we're idling and check for input.
+ If there's an input event, fail to give the system a chance to respond to it in a timely manner.
  If called from machine code then increment the byte count since the clock
  is derived from it and the clock will not advance otherwise.
  If we're simulating threading we're in difficulties.  We need a UI process
  (to run activities such as fill-in-the-blanks) but we also need an independent
  thread of control to run this VM thread.  So we need to fork a new UI process."
  Display reverse: ((displayView
  ifNil: [0@0]
  ifNotNil: [displayView bounds origin]) extent: 16@16).
- Sensor peekEvent ifNotNil:
- [self forceInterruptCheck].
  Processor activeProcess == Project uiProcess ifTrue:
  [World doOneCycle].
+ (stackLimit = self allOnesAsCharStar
+ and: [nextPollUsecs <= self ioUTCMicroseconds])
+ ifTrue:
+ ["Not only do we need to fail, we also need to push time faster
+ since the damn Morphic eventTickler process waits on a delay."
+ "ioUTCMicroseconds"
+ byteCount := byteCount + (1000 * ByteCountsPerMicrosecond).
+ self primitiveFail]
+ ifFalse:
+ [microseconds >= 1000
+ ifTrue: [self isThreadedVM ifTrue:
+ [self forceInterruptCheckFromHeartbeat].
+ (Delay forMilliseconds: microseconds + 999 // 1000) wait]
+ ifFalse: [Processor yield]].
- microseconds >= 1000
- ifTrue: [self isThreadedVM ifTrue:
- [self forceInterruptCheckFromHeartbeat].
- (Delay forMilliseconds: microseconds + 999 // 1000) wait]
- ifFalse: [Processor yield].
  byteCount := byteCount + (microseconds * ByteCountsPerMicrosecond) - 1.
  self incrementByteCount!

Item was changed:
  ----- Method: CogVMSimulator>>ioSetInputSemaphore: (in category 'I/O primitives') -----
  ioSetInputSemaphore: index
+ inputSemaphoreIndex := index!
-
- self primitiveFail!

Item was removed:
- ----- Method: CogVMSimulator>>queueForwardedEvent: (in category 'I/O primitives support') -----
- queueForwardedEvent: event
- eventQueue ifNil:
- [eventQueue := SharedQueue new].
- eventQueue nextPut: event!

Item was changed:
  ----- Method: CogVMSimulator>>signalSemaphoreWithIndex: (in category 'process primitive support') -----
  signalSemaphoreWithIndex: index
+ "Record the given semaphore index in the double buffer semaphores array to be signaled
+ at the next convenient moment. Force a real interrupt check as soon as possible.
+ This is a simulation.  See platforms/Cross/vm/sqExternalSemaphores.c for the real code.
- "This is a simulation.  See platforms/Cross/vm/sqExternalSemaphores.c for the real code.
  Thanks to Levente Uzoni for making this version almost thread-safe (in Smalltalk)"
  <doNotGenerate>
  | originalResponses newRequests newResponses |
  index <= 0 ifTrue: [^false].
  index > externalSemaphoreSignalRequests size ifTrue:
  [newRequests := Array new: 1 << index highBit withAll: 0.
  newResponses := newRequests shallowCopy].
  "This is a lock-free thread-safe grow...; thanks Levente"
  originalResponses := externalSemaphoreSignalResponses.
  [index > externalSemaphoreSignalRequests size] whileTrue:
  [newRequests
  replaceFrom: 1
  to: externalSemaphoreSignalRequests size
  with: externalSemaphoreSignalRequests
  startingAt: 1.
  newResponses
  replaceFrom: 1
  to: externalSemaphoreSignalResponses size
  with: externalSemaphoreSignalResponses
  startingAt: 1.
  externalSemaphoreSignalResponses == originalResponses "This should always be true."
  ifTrue:
  [externalSemaphoreSignalRequests := newRequests.
  externalSemaphoreSignalResponses := newResponses]
  ifFalse:
  [originalResponses := externalSemaphoreSignalResponses]].
  "This is not thread-safe however..."
  externalSemaphoreSignalRequests
  at: index
  put: (externalSemaphoreSignalRequests at: index) + 1.
  ^true!

Item was changed:
  ----- Method: FilePlugin>>primitiveFileReadWithPinning (in category 'file primitives') -----
  primitiveFileReadWithPinning
  "This version of primitiveFileRead is for garbage collectors that support pinning."
  | count startIndex array file slotSize elementSize bytesRead |
  <inline: true>
  <var: 'file' type: #'SQFile *'>
  <var: 'count' type: #'size_t'>
  <var: 'startIndex' type: #'size_t'>
  <var: 'slotSize' type: #'size_t'>
  <var: 'elementSize' type: #'size_t'>
  count := interpreterProxy positiveMachineIntegerValueOf: (interpreterProxy stackValue: 0).
  startIndex := interpreterProxy positiveMachineIntegerValueOf: (interpreterProxy stackValue: 1).
    array := interpreterProxy stackValue: 2.
  file := self fileValueOf: (interpreterProxy stackValue: 3).
 
  (interpreterProxy failed
  "buffer can be any indexable words or bytes object except CompiledMethod"
  or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
  [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
 
  slotSize := interpreterProxy slotSizeOf: array.
  (startIndex >= 1 and: [startIndex + count - 1 <= slotSize]) ifFalse:
  [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
 
  "Note: adjust startIndex for zero-origin byte indexing"
  elementSize := slotSize = 0
  ifTrue: [1]
  ifFalse: [(interpreterProxy byteSizeOf: array) // slotSize].
  bytesRead := self
  sqFile: file
  Read: count * elementSize
  Into: (interpreterProxy cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
  At: startIndex - 1 * elementSize.
  interpreterProxy failed ifFalse:
+ [interpreterProxy methodReturnInteger: bytesRead // elementSize] "answer # of elements read"!
- [interpreterProxy
- methodReturnValue: (interpreterProxy integerObjectOf: bytesRead // elementSize)  "push # of elements read"]!

Item was changed:
  ----- Method: FilePlugin>>primitiveFileReadWithoutPinning (in category 'file primitives') -----
  primitiveFileReadWithoutPinning
  "This version of primitiveFileRead is for garbage collectors without support for pinning."
  | retryCount count startIndex array file elementSize bytesRead |
  <inline: true>
  <var: 'file' type: #'SQFile *'>
  <var: 'count' type: #'size_t'>
  <var: 'startIndex' type: #'size_t'>
  <var: 'elementSize' type: #'size_t'>
  retryCount := 0.
  count := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 0).
  startIndex := interpreterProxy positive32BitValueOf: (interpreterProxy stackValue: 1).
   
  [array := interpreterProxy stackValue: 2.
  file := self fileValueOf: (interpreterProxy stackValue: 3).
 
  (interpreterProxy failed
  "buffer can be any indexable words or bytes object except CompiledMethod"
  or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
  [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
 
  elementSize := (interpreterProxy isWords: array) ifTrue: [4] ifFalse: [1].
  (startIndex >= 1
   and: [(startIndex + count - 1) <= (interpreterProxy slotSizeOf: array)]) ifFalse:
  [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
 
  "Note: adjust startIndex for zero-origin indexing"
  bytesRead := self
  sqFile: file
  Read: count * elementSize
  Into: (interpreterProxy cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
  At: (startIndex - 1) * elementSize.
  interpreterProxy primitiveFailureCode = PrimErrObjectMayMove
  and: [(retryCount := retryCount + 1) <= 2] "Two objects, the file and the array can move"] whileTrue:
  [interpreterProxy
  tenuringIncrementalGC;
  primitiveFailFor: PrimNoErr].
  interpreterProxy failed ifFalse:
  [interpreterProxy
+ methodReturnInteger: bytesRead // elementSize "push # of elements read"]!
- methodReturnValue: (interpreterProxy integerObjectOf: bytesRead // elementSize)  "push # of elements read"]!

Item was changed:
  ----- Method: FilePlugin>>primitiveFileWrite (in category 'file primitives') -----
  primitiveFileWrite
  | count startIndex array file slotSize elementSize bytesWritten |
  <var: 'file' type: 'SQFile *'>
  <var: 'count' type: 'size_t'>
  <var: 'startIndex' type: 'size_t'>
  <var: 'slotSize' type: #'size_t'>
  <var: 'elementSize' type: #'size_t'>
  <export: true>
  count := interpreterProxy positiveMachineIntegerValueOf: (interpreterProxy stackValue: 0).
  startIndex := interpreterProxy positiveMachineIntegerValueOf: (interpreterProxy stackValue: 1).
  array := interpreterProxy stackValue: 2.
  file := self fileValueOf: (interpreterProxy stackValue: 3).
 
  (interpreterProxy failed
  "buffer can be any indexable words or bytes object except CompiledMethod"
  or: [(interpreterProxy isWordsOrBytes: array) not]) ifTrue:
  [^interpreterProxy primitiveFailFor: PrimErrBadArgument].
 
  slotSize := interpreterProxy slotSizeOf: array.
  (startIndex >= 1 and: [startIndex + count - 1 <= slotSize]) ifFalse:
  [^interpreterProxy primitiveFailFor: PrimErrBadIndex].
 
  "Note: adjust startIndex for zero-origin byte indexing"
  elementSize := slotSize = 0
  ifTrue: [1]
  ifFalse: [(interpreterProxy byteSizeOf: array) // slotSize].
  bytesWritten := self
  sqFile: file
  Write: count * elementSize
  From: (interpreterProxy cCoerce: (interpreterProxy firstIndexableField: array) to: #'char *')
  At: startIndex - 1 * elementSize.
  interpreterProxy failed ifFalse:
+ [interpreterProxy methodReturnInteger: bytesWritten // elementSize] "answer # of elements written"!
- [interpreterProxy methodReturnValue: (interpreterProxy integerObjectOf: bytesWritten // elementSize)]!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveRelinquishProcessor (in category 'I/O primitives') -----
  primitiveRelinquishProcessor
  "Relinquish the processor for up to the given number of microseconds. The exact behavior of this primitive is platform dependent."
 
  | microSecs |
  microSecs := self stackIntegerValue: 0.
+ self successful ifTrue:
- self successful ifTrue: [
  "DO NOT allow relinquishing the processor while we are profiling since this
  may skew the time base for our measures (it may reduce processor speed etc).
  Instead we go full speed, therefore measuring the precise time we spend in the
  inner idle loop as a busy loop."
+ [nextProfileTick = 0 ifTrue:
+ [self ioRelinquishProcessorForMicroseconds: microSecs.
+ "In simulation we allow ioRelinquishProcessorForMicroseconds: to fail so that
+  we can arrange that the simulator responds to input events promply.  This
+  *DOES NOT HAPPEN* in the real vm."
+ self cCode: [] inSmalltalk: [primFailCode ~= 0 ifTrue: [^self]]].
+ self pop: 1]  "microSecs; leave rcvr on stack"!
- nextProfileTick = 0 ifTrue:[self ioRelinquishProcessorForMicroseconds: microSecs].
- self pop: 1.  "microSecs; leave rcvr on stack"
- ]!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>newInputEventAccessorOfSize: (in category 'simulation') -----
  newInputEventAccessorOfSize: numElements
  <doNotGenerate>
+ ^CArrayAccessor on: (DoubleWordArray new: 8)!
- self flag: #endianness.
- ^(CPluggableAccessor on: (WordArray new: 16))
- atBlock: [:obj :idx| | v |
- v := (obj at: idx - 1 * 2 + 1) + ((obj at: idx - 1 * 2 + 2) << 32).
- v >> 63 > 0 ifTrue:
- [v := v - (1 << 64)].
- v]
- atPutBlock: [:obj :idx :val|
- obj at: idx - 1 * 2 + 1 put: (val bitAnd: 16rFFFFFFFF).
- obj at: idx - 1 * 2 + 2 put: (val >> 32 bitAnd: 16rFFFFFFFF).
- val];
- objectSize: 8!

Item was added:
+ ----- Method: StackInterpreter>>ioGetNextEvent: (in category 'I/O primitive support') -----
+ ioGetNextEvent: evtBuf
+ <doNotGenerate>
+ "SimulatorMorphicModel browse"
+ ^self eventQueue
+ ifNil: [self primitiveFail]
+ ifNotNil:
+ [:eventQueue|
+ eventQueue nextOrNil ifNotNil:
+ [:evt|
+ 1 to: evt size do:
+ [:i|
+ (evt at: i) ifNotNil:
+ [:val|
+ evtBuf at: i - 1 put: val]]]]!

Item was added:
+ ----- Method: StackInterpreter>>ioProcessEvents (in category 'I/O primitive support') -----
+ ioProcessEvents
+ <doNotGenerate>!

Item was added:
+ ----- Method: StackInterpreter>>queueForwardedEvent: (in category 'I/O primitive support') -----
+ queueForwardedEvent: event
+ "SimulatorMorphicModel browse"
+ <doNotGenerate>
+ self eventQueue nextPut: event.
+ self inputSemaphoreIndex
+ ifNotNil:
+ [:isi| self signalSemaphoreWithIndex: isi]
+ ifNil:
+ [nextPollUsecs := self ioUTCMicroseconds.
+ self forceInterruptCheck]!

Item was changed:
  StackInterpreterPrimitives subclass: #StackInterpreterSimulator
+ instanceVariableNames: 'parent bootstrapping byteCount breakCount sendCount lookupCount printSends printReturns traceOn myBitBlt displayForm fakeForm filesOpen imageName pluginList mappedPluginEntries quitBlock transcript displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize atEachStepBlock disableBooleanCheat performFilters eventQueue assertVEPAES primTraceLog breakBlock inputSemaphoreIndex'
- instanceVariableNames: 'parent bootstrapping byteCount breakCount sendCount lookupCount printSends printReturns traceOn myBitBlt displayForm fakeForm filesOpen imageName pluginList mappedPluginEntries quitBlock transcript displayView eventTransformer printFrameAtEachStep printBytecodeAtEachStep systemAttributes startMicroseconds lastYieldMicroseconds externalSemaphoreSignalRequests externalSemaphoreSignalResponses extSemTabSize atEachStepBlock disableBooleanCheat performFilters eventQueue assertVEPAES primTraceLog breakBlock'
  classVariableNames: ''
  poolDictionaries: ''
  category: 'VMMaker-InterpreterSimulation'!
 
  !StackInterpreterSimulator commentStamp: 'eem 9/3/2013 11:05' prior: 0!
  This class defines basic memory access and primitive simulation so that the StackInterpreter can run simulated in the Squeak environment.  It also defines a number of handy object viewing methods to facilitate pawing around in the object memory.
 
  To see the thing actually run, you could (after backing up this image and changes), execute
 
  (StackInterpreterSimulator new openOn: Smalltalk imageName) test
 
  ((StackInterpreterSimulator newWithOptions: #(NewspeakVM true MULTIPLEBYTECODESETS true))
  openOn: 'ns101.image') test
 
  and be patient both to wait for things to happen, and to accept various things that may go wrong depending on how large or unusual your image may be.  We usually do this with a small and simple benchmark image.
 
  Here's an example of what Eliot uses to launch the simulator in a window.  The bottom-right window has a menu packed with useful stuff:
 
  | vm |
  vm := StackInterpreterSimulator newWithOptions: #().
  vm openOn: '/Users/eliot/Squeak/Squeak4.4/trunk44.image'.
  vm setBreakSelector: #&.
  vm openAsMorph; run!

Item was changed:
  ----- Method: StackInterpreterSimulator>>initialize (in category 'initialization') -----
  initialize
  "Initialize the StackInterpreterSimulator when running the interpreter
  inside Smalltalk. The primary responsibility of this method is to allocate
  Smalltalk Arrays for variables that will be declared as statically-allocated
  global arrays in the translated code."
  super initialize.
 
  bootstrapping := false.
  transcript := Transcript.
 
  objectMemory ifNil:
  [objectMemory := self class objectMemoryClass simulatorClass new].
  objectMemory coInterpreter: self.
 
  self assert: ConstMinusOne = (objectMemory integerObjectOf: -1).
 
  methodCache := Array new: MethodCacheSize.
  nsMethodCache := Array new: NSMethodCacheSize.
  atCache := Array new: AtCacheTotalSize.
  self flushMethodCache.
  gcSemaphoreIndex := 0.
  externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
  externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
  externalPrimitiveTableFirstFreeIndex := 0.
  primitiveTable := self class primitiveTable copy.
  self initializePluginEntries.
  desiredNumStackPages := desiredEdenBytes := 0.
  "This is initialized on loading the image, but convenient for testing stack page values..."
  numStackPages := self defaultNumStackPages.
  startMicroseconds := lastYieldMicroseconds := self ioUTCStartMicroseconds.
 
  "initialize InterpreterSimulator variables used for debugging"
  byteCount := sendCount := lookupCount := 0.
  quitBlock := [^self close].
  traceOn := true.
  printSends := printReturns := printFrameAtEachStep := printBytecodeAtEachStep := false.
  myBitBlt := BitBltSimulator new setInterpreter: self.
  displayForm := fakeForm := 'Display has not yet been installed' asDisplayText form.
- eventQueue := SharedQueue new.
  suppressHeartbeatFlag := false.
  systemAttributes := Dictionary new.
  extSemTabSize := 256.
  disableBooleanCheat := false.
  assertVEPAES := false. "a flag so the assertValidExecutionPointers can be disabled for simulation speed and enabled when necessary."!

Item was added:
+ ----- Method: StackInterpreterSimulator>>inputSemaphoreIndex (in category 'I/O primitive support') -----
+ inputSemaphoreIndex
+ ^inputSemaphoreIndex!

Item was removed:
- ----- Method: StackInterpreterSimulator>>ioGetNextEvent: (in category 'I/O primitives') -----
- ioGetNextEvent: evtBuf
- | evt |
- "SimulatorMorphicModel browse"
- eventQueue ifNil:
- [^self primitiveFail].
- eventQueue isEmpty ifFalse:
- [evt :=  eventQueue next.
- 1 to: evt size do:
- [:i|
- (evt at: i) ifNotNil:
- [:val|
- evtBuf
- at: i - 1
- put: (i = 2 ifTrue: [val bitAnd: MillisecondClockMask] ifFalse: [val])]]]!

Item was removed:
- ----- Method: StackInterpreterSimulator>>ioProcessEvents (in category 'I/O primitives') -----
- ioProcessEvents!

Item was changed:
  ----- Method: StackInterpreterSimulator>>ioRelinquishProcessorForMicroseconds: (in category 'I/O primitives support') -----
  ioRelinquishProcessorForMicroseconds: microseconds
+ "In the simulator give an indication that we're idling and check for input.
+ If there's an input event, fail to give the system a chance to respond to it in a timely manner."
- "In the simulator give an indication that we're idling and check for input."
  Display reverse: ((displayView
  ifNil: [0@0]
  ifNotNil: [displayView bounds origin]) extent: 16@16).
- Sensor peekEvent ifNotNil:
- [self forceInterruptCheck].
  Processor activeProcess == Project uiProcess ifTrue:
  [World doOneCycle].
+ (stackLimit = self allOnesAsCharStar
+ and: [nextPollUsecs <= self ioUTCMicroseconds])
+ ifTrue:
+ ["Not only do we need to fail, we also need to push time faster
+ since the damn Morphic eventTickler process waits on a delay."
+ "ioUTCMicroseconds"
+ byteCount := byteCount + (1000 * 50).
+ self primitiveFail]
+ ifFalse:
+ [microseconds >= 1000
+ ifTrue:
+ [stackLimit = self allOnesAsCharStar ifFalse:
+ [(Delay forMilliseconds: microseconds + 999 // 1000) wait]]
+ ifFalse: [Processor yield]].
- microseconds >= 1000
- ifTrue: [(Delay forMilliseconds: microseconds + 999 // 1000) wait]
- ifFalse: [Processor yield].
  "And increase the byteCount form which the microsecond clock is derived..."
  byteCount := byteCount + microseconds - 1.
  self incrementByteCount!

Item was changed:
  ----- Method: StackInterpreterSimulator>>ioSetInputSemaphore: (in category 'I/O primitives') -----
  ioSetInputSemaphore: index
+ inputSemaphoreIndex := index!
-
- self primitiveFail!

Item was removed:
- ----- Method: StackInterpreterSimulator>>queueForwardedEvent: (in category 'I/O primitives support') -----
- queueForwardedEvent: event
- eventQueue ifNil:
- [eventQueue := SharedQueue new].
- eventQueue nextPut: event!

Item was changed:
  ----- Method: StackInterpreterSimulator>>signalSemaphoreWithIndex: (in category 'process primitive support') -----
  signalSemaphoreWithIndex: index
+ "Record the given semaphore index in the double buffer semaphores array to be signaled
+ at the next convenient moment. Force a real interrupt check as soon as possible.
+ This is a simulation.  See platforms/Cross/vm/sqExternalSemaphores.c for the real code.
- "This is a simulation.  See platforms/Cross/vm/sqExternalSemaphores.c for the real code.
  Thanks to Levente Uzoni for making this version almost thread-safe (in Smalltalk)"
  <doNotGenerate>
  | originalResponses newRequests newResponses |
  index <= 0 ifTrue: [^false].
  index > externalSemaphoreSignalRequests size ifTrue:
  [newRequests := Array new: 1 << index highBit withAll: 0.
  newResponses := newRequests shallowCopy].
  "This is a lock-free thread-safe grow...; thanks Levente"
  originalResponses := externalSemaphoreSignalResponses.
  [index > externalSemaphoreSignalRequests size] whileTrue:
  [newRequests
  replaceFrom: 1
  to: externalSemaphoreSignalRequests size
  with: externalSemaphoreSignalRequests
  startingAt: 1.
  newResponses
  replaceFrom: 1
  to: externalSemaphoreSignalResponses size
  with: externalSemaphoreSignalResponses
  startingAt: 1.
  externalSemaphoreSignalResponses == originalResponses "This should always be true."
  ifTrue:
  [externalSemaphoreSignalRequests := newRequests.
  externalSemaphoreSignalResponses := newResponses]
  ifFalse:
  [originalResponses := externalSemaphoreSignalResponses]].
  "This is not thread-safe however..."
  externalSemaphoreSignalRequests
  at: index
  put: (externalSemaphoreSignalRequests at: index) + 1.
  ^true!