[Vm-dev] VM Maker: VMMaker.oscog-eem.400.mcz

commits at source.squeak.org commits at source.squeak.org
Sat Sep 21 14:51:24 UTC 2013 

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

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

Name: VMMaker.oscog-eem.400
Author: eem
Time: 21 September 2013, 7:46:26.362 am
UUID: 3481cf9c-80d0-47db-b5c4-07102f7ea255
Ancestors: VMMaker.oscog-eem.399

Make the Inflate/DeflatePlugin simulate.

Simplify loadColorMapShiftOrMaskFrom: & others; isWords:,
isBytes: et al check for immediates already.

Add printHexnp: for unpadded hex printing & use in longPrintOop:.

Add a print stack call stack to print less stack :)

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

Item was changed:
  ----- Method: BitBltSimulation>>loadColorMapShiftOrMaskFrom: (in category 'interpreter interface') -----
  loadColorMapShiftOrMaskFrom: mapOop
  	<returnTypeC:'void *'>
  	mapOop = interpreterProxy nilObject ifTrue:[^nil].
- 	(interpreterProxy isIntegerObject: mapOop) 
- 		ifTrue:[interpreterProxy primitiveFail. ^nil].
  	((interpreterProxy isWords: mapOop) 
  		and:[(interpreterProxy slotSizeOf: mapOop) = 4])
  			ifFalse:[interpreterProxy primitiveFail. ^nil].
  	^interpreterProxy firstIndexableField: mapOop!

Item was added:
+ ----- Method: InflatePlugin class>>simulatorClass (in category 'simulation') -----
+ simulatorClass
+ 	"For running from Smalltalk - answer a class that can be used to simulate the receiver,
+ 	 or nil if you want the primitives in this module to always fail, causing simulation to fall
+ 	 through to the Smalltalk code.  By default every non-TestInterpreterPlugin can simulate itself."
+ 
+ 	^DeflatePlugin!

Item was changed:
  ----- Method: InflatePlugin>>primitiveInflateDecompressBlock (in category 'primitives') -----
  primitiveInflateDecompressBlock
  	"Primitive. Inflate a single block."
  	| oop rcvr |
  	<export: true>
+ 	interpreterProxy methodArgumentCount = 2 ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 	interpreterProxy methodArgumentCount = 2 ifFalse:[^interpreterProxy primitiveFail].
  	"distance table"
+ 	oop := interpreterProxy stackValue: 0.
+ 	(interpreterProxy isWords: oop) ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 	oop := interpreterProxy stackObjectValue: 0.
- 	interpreterProxy failed ifTrue:[^nil].
- 	(interpreterProxy isWords: oop)
- 		ifFalse:[^interpreterProxy primitiveFail].
  	zipDistTable := interpreterProxy firstIndexableField: oop.
  	zipDistTableSize := interpreterProxy slotSizeOf: oop.
  
  	"literal table"
+ 	oop := interpreterProxy stackValue: 1.
+ 	(interpreterProxy isWords: oop) ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 	oop := interpreterProxy stackObjectValue: 1.
- 	interpreterProxy failed ifTrue:[^nil].
- 	(interpreterProxy isWords: oop)
- 		ifFalse:[^interpreterProxy primitiveFail].
  	zipLitTable := interpreterProxy firstIndexableField: oop.
  	zipLitTableSize := interpreterProxy slotSizeOf: oop.
  
  
  	"Receiver (InflateStream)"
+ 	rcvr := interpreterProxy stackValue: 2.
+ 	(interpreterProxy isPointers: rcvr) ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 	rcvr := interpreterProxy stackObjectValue: 2.
- 	interpreterProxy failed ifTrue:[^nil].
- 	(interpreterProxy isPointers: rcvr)
- 		ifFalse:[^interpreterProxy primitiveFail].
  	(interpreterProxy slotSizeOf: rcvr) < 9
  		ifTrue:[^interpreterProxy primitiveFail].
  
  	"All the integer instvars"
  	zipReadLimit := interpreterProxy fetchInteger: 2 ofObject: rcvr.
  	zipState := interpreterProxy fetchInteger: 3 ofObject: rcvr.
  	zipBitBuf := interpreterProxy fetchInteger: 4 ofObject: rcvr.
  	zipBitPos := interpreterProxy fetchInteger: 5 ofObject: rcvr.
  	zipSourcePos := interpreterProxy fetchInteger: 7 ofObject: rcvr.
  	zipSourceLimit := interpreterProxy fetchInteger: 8 ofObject: rcvr.
  	interpreterProxy failed ifTrue:[^nil].
  	zipReadLimit := zipReadLimit - 1.
  	zipSourcePos := zipSourcePos - 1.
  	zipSourceLimit := zipSourceLimit - 1.
  
  	"collection"
  	oop := interpreterProxy fetchPointer: 0 ofObject: rcvr.
+ 	(interpreterProxy isBytes: oop) ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 	(interpreterProxy isIntegerObject: oop)
- 		ifTrue:[^interpreterProxy primitiveFail].
- 	(interpreterProxy isBytes: oop)
- 		ifFalse:[^interpreterProxy primitiveFail].
  	zipCollection := interpreterProxy firstIndexableField: oop.
  	zipCollectionSize := interpreterProxy byteSizeOf: oop.
  
  	"source"
  	oop := interpreterProxy fetchPointer: 6 ofObject: rcvr.
+ 	(interpreterProxy isBytes: oop) ifFalse:
+ 		[^interpreterProxy primitiveFail].
- 	(interpreterProxy isIntegerObject: oop)
- 		ifTrue:[^interpreterProxy primitiveFail].
- 	(interpreterProxy isBytes: oop)
- 		ifFalse:[^interpreterProxy primitiveFail].
  	zipSource := interpreterProxy firstIndexableField: oop.
  
  	"do the primitive"
  	self zipDecompressBlock.
+ 	interpreterProxy failed ifFalse: "store modified values back"
+ 		[interpreterProxy storeInteger: 2 ofObject: rcvr withValue: zipReadLimit + 1.
- 	interpreterProxy failed ifFalse:[
- 		"store modified values back"
- 		interpreterProxy storeInteger: 2 ofObject: rcvr withValue: zipReadLimit + 1.
  		interpreterProxy storeInteger: 3 ofObject: rcvr withValue: zipState.
  		interpreterProxy storeInteger: 4 ofObject: rcvr withValue: zipBitBuf.
  		interpreterProxy storeInteger: 5 ofObject: rcvr withValue: zipBitPos.
  		interpreterProxy storeInteger: 7 ofObject: rcvr withValue: zipSourcePos + 1.
+ 		interpreterProxy pop: 2]!
- 		interpreterProxy pop: 2.
- 	].!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveIntegerAt (in category 'sound primitives') -----
  primitiveIntegerAt
  	"Return the 32bit signed integer contents of a words receiver"
  
  	| index rcvr sz addr value intValue |
  	<var: #intValue type: 'int'>
  	index := self stackIntegerValue: 0.
  	self successful ifFalse:
  		[^self primitiveFailFor: PrimErrBadArgument].
  	rcvr := self stackValue: 1.
+ 	(objectMemory isWords: rcvr) ifFalse:
- 	((objectMemory isIntegerObject: rcvr)
- 	or: [(objectMemory isWords: rcvr) not]) ifTrue:
  		[^self primitiveFailFor: PrimErrInappropriate].
  	sz := objectMemory lengthOf: rcvr.  "number of fields"
  	((index >= 1) and: [index <= sz]) ifFalse:
  		[^self primitiveFailFor: PrimErrBadIndex].
+ 	"4 = 32 bits / 8"
+ 	addr := rcvr + objectMemory baseHeaderSize + (index - 1 * 4). "for zero indexing"
+ 	value := objectMemory intAt: addr.
- 	addr := rcvr + BaseHeaderSize + (index - 1 * BytesPerWord). "for zero indexing"
- 	value := self intAt: addr.
  	self pop: 2.  "pop rcvr, index"
  	"push element value"
  	(objectMemory isIntegerValue: value)
  		ifTrue: [self pushInteger: value]
  		ifFalse: [intValue := value. "32 bit int may have been stored in 32 or 64 bit sqInt"
  				self push: (self signed32BitIntegerFor: intValue)] "intValue may be sign extended to 64 bit sqInt"!

Item was changed:
  ----- Method: InterpreterPrimitives>>primitiveIntegerAtPut (in category 'sound primitives') -----
  primitiveIntegerAtPut
  	"Return the 32bit signed integer contents of a words receiver"
  	| index rcvr sz addr value valueOop |
  	<var: 'value' type: 'int'>
  	valueOop := self stackValue: 0.
  	index := self stackIntegerValue: 1.
  	value := self signed32BitValueOf: valueOop.
  	self successful ifFalse:
  		[^self primitiveFailFor: PrimErrBadArgument].
  	rcvr := self stackValue: 2.
+ 	(objectMemory isWords: rcvr) ifFalse:
- 	((objectMemory isIntegerObject: rcvr)
- 	or: [(objectMemory isWords: rcvr) not]) ifTrue:
  		[^self primitiveFailFor: PrimErrInappropriate].
  	sz := objectMemory lengthOf: rcvr.  "number of fields"
  	(index >= 1 and: [index <= sz]) ifFalse:
  		[^self primitiveFailFor: PrimErrBadIndex].
+ 	"4 = 32 bits / 8"
+ 	addr := rcvr + objectMemory baseHeaderSize + (index - 1 * 4). "for zero indexing"
+ 	value := objectMemory intAt: addr put: value.
- 	addr := rcvr + BaseHeaderSize + (index - 1 * BytesPerWord). "for zero indexing"
- 	value := self intAt: addr put: value.
  	self pop: 3 thenPush: valueOop "pop all; return value"
  !

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>intAt:put: (in category 'memory access') -----
+ intAt: byteAddress put: a32BitValue
+ 	^self longAt: byteAddress put: (a32BitValue bitAnd: 16rFFFFFFFF)!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>storeInteger:ofObject:withValue: (in category 'simulation only') -----
+ storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue
+ 	"hack around the CoInterpreter/ObjectMemory split refactoring"
+ 	^coInterpreter storeInteger: fieldIndex ofObject: objectPointer withValue: integerValue!

Item was changed:
  ----- Method: SpurMemoryManager>>isIntegerObject: (in category 'object testing') -----
  isIntegerObject: oop
  	"This list records the valid senders of isIntegerObject: as we replace uses of
  	  isIntegerObject: by isImmediate: where appropriate."
  	| sel |
  	sel := thisContext sender method selector.
  	(#(	DoIt
  		DoItIn:
  		on:do: "from the debugger"
  		makeBaseFrameFor:
  		quickFetchInteger:ofObject:
  		frameOfMarriedContext:
  		objCouldBeClassObj:
  		isMarriedOrWidowedContext:
  		shortPrint:
  		bytecodePrimAt
  		bytecodePrimAtPut
  		commonAt:
  		commonAtPut:
  		loadFloatOrIntFrom:
  		positive32BitValueOf:
  		primitiveExternalCall
  		checkedIntegerValueOf:
  		bytecodePrimAtPut
  		commonAtPut:
  		primitiveVMParameter
  		checkIsStillMarriedContext:currentFP:
  		displayBitsOf:Left:Top:Right:Bottom:
  		fetchStackPointerOf:
  		primitiveContextAt
  		primitiveContextAtPut
  		subscript:with:storing:format:
  		printContext:
  		compare31or32Bits:equal:
  		signed64BitValueOf:
  		primDigitMultiply:negative:
  		digitLength:
  		isNegativeIntegerValueOf:
  		magnitude64BitValueOf:
  		primitiveMakePoint
  		primitiveAsCharacter
  		primitiveInputSemaphore
  		baseFrameReturn
  		primitiveExternalCall
  		primDigitCompare:
  		isLiveContext:
  		numPointerSlotsOf:
  		fileValueOf:
  		loadBitBltDestForm
  		fetchIntOrFloat:ofObject:ifNil:
  		fetchIntOrFloat:ofObject:
  		loadBitBltSourceForm
  		loadPoint:from:
  		primDigitAdd:
  		primDigitSubtract:
+ 		positive64BitValueOf:
+ 		digitBitLogic:with:opIndex:
+ 		signed32BitValueOf:) includes: sel) ifFalse:
- 		positive64BitValueOf:) includes: sel) ifFalse:
  		[self halt].
  	^(oop bitAnd: 1) ~= 0!

Item was changed:
  ----- Method: StackInterpreter>>longPrintOop: (in category 'debug printing') -----
  longPrintOop: oop
  	<api>
  	| class fmt lastIndex startIP bytecodesPerLine column |
  	((objectMemory isImmediate: oop)
  	 or: [(objectMemory addressCouldBeObj: oop) not
  	 or: [(oop bitAnd: objectMemory allocationUnit - 1) ~= 0
  	 or: [(objectMemory isFreeObject: oop)
  	 or: [objectMemory isForwarded: oop]]]]) ifTrue:
  		[^self printOop: oop].
  	class := objectMemory fetchClassOfNonImm: oop.
  	self printHex: oop;
  		print: ': a(n) '; printNameOfClass: class count: 5;
  		print: ' ('; printHex: class; print: ')'.
  	fmt := objectMemory formatOf: oop.
+ 	self print: ' format '; printHexnp: fmt.
- 	self print: ' format '; printHex: fmt.
  	fmt > objectMemory lastPointerFormat ifTrue:
  		[self print: ' nbytes '; printNum: (objectMemory byteLengthOf: oop)].
  	objectMemory printHeaderTypeOf: oop.
+ 	self print: ' hash '; printHexnp: (objectMemory rawHashBitsOf: oop).
- 	self print: ' hash '; printHex: (objectMemory rawHashBitsOf: oop).
  	self cr.
  	(fmt between: objectMemory firstLongFormat and: objectMemory firstCompiledMethodFormat - 1) ifTrue:
  		[^self].
  	"this is nonsense.  apologies."
  	startIP := (objectMemory lastPointerOf: oop) + BytesPerOop - objectMemory baseHeaderSize / BytesPerOop.
  	lastIndex := 256 min: startIP.
  	lastIndex > 0 ifTrue:
  		[1 to: lastIndex do:
  			[:i| | fieldOop |
  			fieldOop := objectMemory fetchPointer: i - 1 ofObject: oop.
  			self space; printNum: i - 1; space; printHex: fieldOop; space.
  			(i = 1 and: [objectMemory isCompiledMethod: oop])
  				ifTrue: [self printMethodHeaderOop: fieldOop]
  				ifFalse: [self printOopShort: fieldOop].
  			self cr]].
  	(objectMemory isCompiledMethod: oop)
  		ifFalse:
  			[startIP > 64 ifTrue: [self print: '...'; cr]]
  		ifTrue:
  			[startIP := startIP * BytesPerWord + 1.
  			 lastIndex := objectMemory lengthOf: oop.
  			 lastIndex - startIP > 100 ifTrue:
  				[lastIndex := startIP + 100].
  			 bytecodesPerLine := 8.
  			 column := 1.
  			 startIP to: lastIndex do:
  				[:index| | byte |
  				column = 1 ifTrue:
  					[self cCode: 'printf("0x%08x: ", oop+BaseHeaderSize+index-1)'
  						inSmalltalk: [self print: (oop+BaseHeaderSize+index-1) hex; print: ': ']].
  				byte := objectMemory fetchByte: index - 1 ofObject: oop.
  				self cCode: 'printf(" %02x/%-3d", byte,byte)'
  					inSmalltalk: [self space; print: (byte radix: 16); printChar: $/; printNum: byte].
  				column := column + 1.
  				column > bytecodesPerLine ifTrue:
  					[column := 1. self cr]].
  			column = 1 ifFalse:
  				[self cr]]!

Item was changed:
  ----- Method: StackInterpreter>>printCallStackOf: (in category 'debug printing') -----
+ printCallStackOf: aContextOrProcessOrFrame
- printCallStackOf: aContextOrProcess
  	<api>
  	| context |
  	<inline: false>
  	<var: #theFP type: #'char *'>
+ 	(stackPages couldBeFramePointer: aContextOrProcessOrFrame) ifTrue:
+ 		[^self printCallStackFP: (self cCoerceSimple: aContextOrProcessOrFrame to: #'char *')].
+ 	((objectMemory isContext: aContextOrProcessOrFrame) not
+ 	and: [(objectMemory lengthOf: aContextOrProcessOrFrame) > MyListIndex
- 	((objectMemory isContext: aContextOrProcess) not
- 	and: [(objectMemory lengthOf: aContextOrProcess) > MyListIndex
  	and: [objectMemory isContext: (objectMemory
  									fetchPointer: SuspendedContextIndex
+ 									ofObject: aContextOrProcessOrFrame)]]) ifTrue:
- 									ofObject: aContextOrProcess)]]) ifTrue:
  		[^self printCallStackOf: (objectMemory
  									fetchPointer: SuspendedContextIndex
+ 									ofObject: aContextOrProcessOrFrame)].
+ 	context := aContextOrProcessOrFrame.
- 									ofObject: aContextOrProcess)].
- 	context := aContextOrProcess.
  	[context = objectMemory nilObject] whileFalse:
  		[(self isMarriedOrWidowedContext: context)
  			ifTrue:
  				[(self checkIsStillMarriedContext: context currentFP: framePointer) ifFalse:
  					[self shortPrintContext: context.
  					 ^nil].
  				 context := self shortReversePrintFrameAndCallers: (self frameOfMarriedContext: context)]
  			ifFalse:
  				[context := self printContextCallStackOf: context]]!

Item was added:
+ ----- Method: StackInterpreter>>printHexnp: (in category 'debug printing') -----
+ printHexnp: n
+ 	"Print n in hex,  in the form '0x1234', unpadded"
+ 	self print: '0x%x' f: n!

Item was added:
+ ----- Method: StackInterpreter>>printStackCallStack (in category 'debug printing') -----
+ printStackCallStack
+ 	<doNotGenerate>
+ 	| theFP context |
+ 	theFP := localFP.
+ 	[context := self shortReversePrintFrameAndCallers: theFP.
+ 	 ((self isMarriedOrWidowedContext: context)
+ 	  and: [self checkIsStillMarriedContext: context currentFP: localFP]) ifFalse:
+ 		[^nil].
+ 	 theFP := self frameOfMarriedContext: context] repeat!

Item was added:
+ ----- Method: StackInterpreterSimulator>>printHexnp: (in category 'debug printing') -----
+ printHexnp: anInteger
+ 
+ 	traceOn ifTrue:
+ 		[transcript nextPutAll: (anInteger storeStringBase: 16)]!

Item was changed:
  ----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
  utilitiesMenu: aMenuMorph
  	aMenuMorph
  		add: 'toggle transcript' action: #toggleTranscript;
  		addLine;
  		add: 'print ext head frame' action: #printExternalHeadFrame;
  		add: 'print int head frame' action: #printHeadFrame;
  		add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
  		add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
  		add: 'long print ext frame & callers' action: [self printFrameAndCallers: framePointer SP: stackPointer];
  		add: 'long print int frame & callers' action: [self printFrameAndCallers: localFP SP: localSP];
  		add: 'print frame...' action: [(self promptHex: 'print frame') ifNotNil: [:fp| self printFrame: fp]];
  		add: 'print call stack' action: #printCallStack;
+ 		add: 'print stack call stack' action: #printStackCallStack;
  		add: 'print call stack of...' action: [(self promptHex: 'context or process oop') ifNotNil: [:obj| self printCallStackOf: obj]];
  		add: 'print all stacks' action: #printAllStacks;
+ 		add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP.
+ 											self writeBackHeadFramePointers];
  		addLine;
  		add: 'print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self printOop: oop]];
  		add: 'long print oop...' action: [(self promptHex: 'print oop') ifNotNil: [:oop| self longPrintOop: oop]];
  		addLine;
  		add: 'inspect object memory' target: objectMemory action: #inspect;
  		add: 'inspect cointerpreter' action: #inspect;
  		addLine;
  		add: 'set break count...' action: [|s| s := UIManager default request: 'break count (dec)'.
  											s notEmpty ifTrue: [breakCount := Integer readFrom: s readStream]];
  		add: 'set break selector...' action: [|s| s := UIManager default request: 'break selector'.
  											s notEmpty ifTrue: [self setBreakSelector: s]];
  		add: (printSends
  				ifTrue: ['no print sends']
  				ifFalse: ['print sends'])
  			action: [self ensureDebugAtEachStepBlock.
  					printSends := printSends not];
  		"currently printReturns does nothing"
  		"add: (printReturns
  				ifTrue: ['no print returns']
  				ifFalse: ['print returns'])
  			action: [self ensureDebugAtEachStepBlock.
  					printReturns := printReturns not];"
  		add: (printBytecodeAtEachStep
  				ifTrue: ['no print bytecode each bytecode']
  				ifFalse: ['print bytecode each bytecode'])
  			action: [self ensureDebugAtEachStepBlock.
  					printBytecodeAtEachStep := printBytecodeAtEachStep not];
  		add: (printFrameAtEachStep
  				ifTrue: ['no print frame each bytecode']
  				ifFalse: ['print frame each bytecode'])
  			action: [self ensureDebugAtEachStepBlock.
  					printFrameAtEachStep := printFrameAtEachStep not].
  	^aMenuMorph!

More information about the Vm-dev mailing list