'From Pharo2.0 of 7 March 2013 [Latest update: #20628] on 13 February 2014 at 11:27:20 am'!

!VMClass methodsFor: 'simulation support' stamp: 'PhilippeBack 11/27/2013 21:28'!
doOrDefer: aBlock
	<doNotGenerate>
	"Either evaluate aBlock immediately if in the uiProcess or defer aBlock as a UI message"
	Processor activeProcess == UIManager default uiProcess
		ifTrue: [aBlock value]
		ifFalse: [WorldState addDeferredUIMessage: aBlock]! !


!ByteString methodsFor: 'comparing' stamp: 'MrVMMaker 11/27/2013 16:54'!
findSubstring: key in: body startingAt: start matchTable: matchTable
	"Answer the index in the string body at which the substring key first occurs, at or beyond start.  The match is determined using matchTable, which can be used to effect, eg, case-insensitive matches.  If no match is found, zero will be returned.

	The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter."
	| index |
	<primitive: 'primitiveFindSubstring' module: 'MiscPrimitivePlugin'>
	
	<var: #key declareC: 'unsigned char *key'>
	<var: #body declareC: 'unsigned char *body'>
	<var: #matchTable declareC: 'unsigned char *matchTable'>

	key size = 0 ifTrue: [^ 0].
	start to: body size - key size + 1 do:
		[:startIndex |
		index := 1.
			[(matchTable at: (body at: startIndex+index-1) asciiValue + 1)
				= (matchTable at: (key at: index) asciiValue + 1)]
				whileTrue:
				[index = key size ifTrue: [^ startIndex].
				index := index+1]].
	^ 0
! !


!StackInterpreterSimulator methodsFor: 'UI' stamp: 'PhilippeBack 11/27/2013 21:24'!
openAsMorph
	"Open a morphic view on this simulation."
	| window localImageName |
	"localImageName := FileSystem workingDirectory localNameFor: imageName."
	window := (SystemWindow labelled: 'Simulation of ', imageName) model: self.

	window addMorph: (displayView := ImageMorph new image: displayForm)
		frame: (0@0 corner: 1@0.8).

	transcript := Transcript.
	window addMorph: (PluggableTextMorph
							on: transcript text: nil accept: nil
							readSelection: nil menu: #codePaneMenu:shifted:)
			frame: (0@0.8 corner: 0.7@1).

	window addMorph: (PluggableTextMorph on: self
						text: #byteCountText accept: nil
						readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
			frame: (0.7@0.8 corner: 1@1).

	window openInWorldExtent: (self desiredDisplayExtent
								+ (2 * window borderWidth)
								+ (0@window labelHeight)
								* (1@(1/0.8))) rounded! !

!StackInterpreterSimulator methodsFor: 'initialization' stamp: 'PhilippeBack 11/27/2013 22:00'!
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."

	| objectMemoryClass |

	"initialize class variables"
	objectMemory ifNotNil:
		[^self halt].

	objectMemoryClass := self class objectMemoryClass.

	objectMemoryClass initBytesPerWord: objectMemoryClass bytesPerWord.
	objectMemoryClass initialize.
	StackInterpreter initialize.

	super initialize.
	objectMemory := objectMemoryClass simulatorClass new.
	objectMemory coInterpreter: self.

	"Note: we must initialize ConstMinusOne differently for simulation,
		due to the fact that the simulator works only with +ve 32-bit values"
	ConstMinusOne := objectMemory integerObjectOf: -1.

	methodCache := Array new: MethodCacheSize.
	atCache := Array new: AtCacheTotalSize.
	self flushMethodCache.
	self flushAtCache.
	gcSemaphoreIndex := 0.
	externalSemaphoreSignalRequests := externalSemaphoreSignalResponses := #().
	externalPrimitiveTable := CArrayAccessor on: (Array new: MaxExternalPrimitiveTableSize).
	externalPrimitiveTableFirstFreeIndex := 0.
	primitiveTable := self class primitiveTable copy.
	pluginList := #().
	mappedPluginEntries := #().
	desiredNumStackPages := desiredEdenBytes := 0.
	"This is initialized on loading the image, but convenient for testing stack page values..."
	numStackPages := self defaultNumStackPages. 
	startMicroseconds := Time totalSeconds * 1000000.

	"initialize InterpreterSimulator variables used for debugging"
	byteCount := 0.
	sendCount := 0.
	quitBlock := [^ self].
	traceOn := true.
	printSends := printReturns := printFrameAtEachStep := printBytecodeAtEachStep := false.
	myBitBlt := BitBltSimulator new setInterpreter: self.
	transcript := Transcript.
	displayForm := (ImageMorph fromString: 'Display has not yet been installed') form.
	suppressHeartbeatFlag := false.
	extSemTabSize := 256.
	disableBooleanCheat := false! !

!StackInterpreterSimulator methodsFor: 'initialization' stamp: 'PhilippeBack 11/27/2013 21:04'!
openOn: fileName extraMemory: extraBytes
	"InterpreterSimulator new openOn: 'clone.im' extraMemory: 100000"

	| f version headerSize count oldBaseAddr bytesToShift swapBytes
	  hdrNumStackPages hdrEdenBytes headerFlags |
	"open image file and read the header"

	["begin ensure block..."
	f := FileStream readOnlyFileNamed: fileName.
	imageName := f fullName.
	f binary.
	version := self nextLongFrom: f.  "current version: 16r1968 (=6504) vive la revolucion!!"
	(self readableFormat: version)
		ifTrue: [swapBytes := false]
		ifFalse: [(version := objectMemory byteSwapped: version) = self imageFormatVersion
					ifTrue: [swapBytes := true]
					ifFalse: [self error: 'incomaptible image format']].
	headerSize := self nextLongFrom: f swap: swapBytes.
	objectMemory setEndOfMemory: (self nextLongFrom: f swap: swapBytes).  "first unused location in heap"
	oldBaseAddr := self nextLongFrom: f swap: swapBytes.  "object memory base address of image"
	objectMemory specialObjectsOop: (self nextLongFrom: f swap: swapBytes).
	objectMemory lastHash: (self nextLongFrom: f swap: swapBytes).  "Should be loaded from, and saved to the image header"

	savedWindowSize	:= self nextLongFrom: f swap: swapBytes.
	headerFlags			:= self nextLongFrom: f swap: swapBytes.
	self setImageHeaderFlagsFrom: headerFlags.
	extraVMMemory		:= self nextLongFrom: f swap: swapBytes.
	hdrNumStackPages	:= self nextShortFrom: f swap: swapBytes.
	"4 stack pages is small.  Should be able to run with as few as
	 three. 4 should be comfortable but slow.  8 is a reasonable
	 default. Can be changed via vmParameterAt: 43 put: n"
	numStackPages := desiredNumStackPages ~= 0
						ifTrue: [desiredNumStackPages]
						ifFalse: [hdrNumStackPages = 0
									ifTrue: [self defaultNumStackPages]
									ifFalse: [hdrNumStackPages]].
	desiredNumStackPages := hdrNumStackPages.
	stackPages := self stackPagesClass new. "Temporary for computeStackZoneSize"
	"pad to word boundary.  This slot can be used for anything else that will fit in 16 bits.
	 Preserve it to be polite to images run on Cog."
	theUnknownShort	:= self getShortFromFile: f swap: swapBytes.
	hdrEdenBytes		:= self nextLongFrom: f swap: swapBytes.
	objectMemory edenBytes: (hdrEdenBytes = 0
							ifTrue: [objectMemory defaultEdenBytes]
							ifFalse: [hdrEdenBytes]).
	desiredEdenBytes := hdrEdenBytes.
	"allocate interpreter memory"
	objectMemory setMemoryLimit: objectMemory endOfMemory + extraBytes + objectMemory edenBytes + self interpreterAllocationReserveBytes.

	"read in the image in bulk, then swap the bytes if necessary"
	f position: headerSize.
	objectMemory memory: (Bitmap new: objectMemory memoryLimit // 4).
	count := f readInto: objectMemory memory startingAt: 1 count: objectMemory endOfMemory // 4.
	count ~= (objectMemory endOfMemory // 4) ifTrue: [self halt].
	]
		ensure: [f close].

	self ensureImageFormatIsUpToDate: swapBytes.

	objectMemory initialize.
	bytesToShift := objectMemory startOfMemory - oldBaseAddr.  "adjust pointers for zero base address"
	UIManager default informUser: 'Relocating object pointers...'
				during: [self initializeInterpreter: bytesToShift].
! !

!StackInterpreterSimulator methodsFor: 'other primitives' stamp: 'PhilippeBack 11/27/2013 21:29'!
primitiveGetAttribute
	"Fetch the system attribute with the given integer ID. The result is a string, which will be empty if the attribute is not defined."

	| attr s attribute |
	attr := self stackIntegerValue: 0.
	self successful ifTrue: [
		attribute := Smalltalk vm getSystemAttribute: attr.
		attribute ifNil: [ ^self primitiveFail ].
		s := objectMemory instantiateClass: (objectMemory splObj: ClassByteString) indexableSize: attribute size.
		1 to: attribute size do: [ :i |
			objectMemory storeByte: i-1 ofObject: s withValue: (attribute at: i) asciiValue].
		self pop: 2.  "rcvr, attr"
		self push: s]! !

!StackInterpreterSimulator methodsFor: 'I/O primitive support' stamp: 'PhilippeBack 11/27/2013 21:29'!
ioRelinquishProcessorForMicroseconds: microseconds
	"In the simulator give an indication that we're idling and check for input."
	Display reverse: (0@0 extent: 16@16).
	Sensor peekEvent ifNotNil:
		[self forceInterruptCheck].
	Processor activeProcess == UIManager default uiProcess ifTrue:
		[World doOneCycle].
	microseconds >= 1000
		ifTrue: [(Delay forMilliseconds: microseconds + 999 // 1000) wait]
		ifFalse: [Processor yield]! !