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

commits at source.squeak.org commits at source.squeak.org
Thu Dec 5 19:29:26 UTC 2013


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

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

Name: VMMaker.oscog-eem.535
Author: eem
Time: 5 December 2013, 11:28:53.014 am
UUID: 7b0d92a3-e58b-49ac-b91f-a69db5b70f20
Ancestors: VMMaker.oscog-eem.534

Fix bounds check in Spur machine-code String at:.

add print call stack of frame to utilities menus, and
printCogMethodsWithPrimtiive: as api and utilities menu.

Make SpurMemoryManager>>lookupAddress: a little safter.

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

Item was added:
+ ----- Method: CogMethodZone>>printCogMethodsWithPrimitive: (in category 'printing') -----
+ printCogMethodsWithPrimitive: primIdx
+ 	<api>
+ 	| cogMethod |
+ 	<var: #cogMethod type: #'CogMethod *'>
+ 	cogMethod := coInterpreter cCoerceSimple: baseAddress to: #'CogMethod *'.
+ 	[cogMethod < self limitZony] whileTrue:
+ 		[(cogMethod cmType ~= CMFree
+ 		  and: [primIdx = (coInterpreter primitiveIndexOfMethod: cogMethod methodObject
+ 							header: cogMethod methodHeader)]) ifTrue:
+ 			[coInterpreter printCogMethod: cogMethod].
+ 		 cogMethod := self methodAfter: cogMethod]!

Item was changed:
  ----- Method: CogObjectRepresentationFor32BitSpur>>genInnerPrimitiveAt: (in category 'primitive generators') -----
  genInnerPrimitiveAt: retNoffset
  	"Implement the guts of primitiveAt; dispatch on size"
  	| formatReg jumpNotIndexable jumpSmallSize jumpImmediate jumpBadIndex
  	  jumpBytesDone jumpShortsDone jumpWordsDone jumpFixedFieldsDone
  	  jumpIsBytes jumpIsShorts jumpIsWords jumpWordTooBig jumpIsArray jumpHasFixedFields jumpIsContext
  	  jumpBytesOutOfBounds jumpShortsOutOfBounds jumpWordsOutOfBounds jumpArrayOutOfBounds jumpFixedFieldsOutOfBounds |
  	<inline: true>
  	"c.f. StackInterpreter>>stSizeOf: SpurMemoryManager>>lengthOf:format: fixedFieldsOf:format:length:"
  	<var: #jumpIsBytes type: #'AbstractInstruction *'>
  	<var: #jumpIsShorts type: #'AbstractInstruction *'>
  	<var: #jumpBadIndex type: #'AbstractInstruction *'>
  	<var: #jumpSmallSize type: #'AbstractInstruction *'>
  	<var: #jumpIsContext type: #'AbstractInstruction *'>
  	<var: #jumpImmediate type: #'AbstractInstruction *'>
  	<var: #jumpBytesDone type: #'AbstractInstruction *'>
  	<var: #jumpShortsDone type: #'AbstractInstruction *'>
  	<var: #jumpWordsDone type: #'AbstractInstruction *'>
  	<var: #jumpWordTooBig type: #'AbstractInstruction *'>
  	<var: #jumpNotIndexable type: #'AbstractInstruction *'>
  	<var: #jumpHasFixedFields type: #'AbstractInstruction *'>
  	<var: #jumpFixedFieldsDone type: #'AbstractInstruction *'>
  	<var: #jumpArrayOutOfBounds type: #'AbstractInstruction *'>
  	<var: #jumpBytesOutOfBounds type: #'AbstractInstruction *'>
  	<var: #jumpShortsOutOfBounds type: #'AbstractInstruction *'>
  	<var: #jumpWordsOutOfBounds type: #'AbstractInstruction *'>
  	<var: #jumpFixedFieldsOutOfBounds type: #'AbstractInstruction *'>
  
  	cogit MoveR: ReceiverResultReg R: TempReg.
  	jumpImmediate := self genJumpImmediateInScratchReg: TempReg.
  	cogit MoveR: Arg0Reg R: TempReg.
+ 	cogit MoveR: Arg0Reg R: Arg1Reg.
  	jumpBadIndex := self genJumpNotSmallIntegerInScratchReg: TempReg.
+ 	self genConvertSmallIntegerToIntegerInScratchReg: Arg1Reg.
+ 	cogit SubCq: 1 R: Arg1Reg. "1-rel => 0-rel"
- 	self genConvertSmallIntegerToIntegerInScratchReg: Arg0Reg.
- 	cogit SubCq: 1 R: Arg0Reg. "1-rel => 0-rel"
  
  	formatReg := SendNumArgsReg.
  	cogit
  		MoveMw: 0 r: ReceiverResultReg R: formatReg;		"formatReg := least significant half of self baseHeader: receiver"
  		MoveR: formatReg R: TempReg;
  		LogicalShiftRightCq: objectMemory formatShift R: formatReg;
  		AndCq: objectMemory formatMask R: formatReg.	"formatReg := self formatOfHeader: destReg"
  
  	"get numSlots into ClassReg."
  	cogit MoveCq: 0 R: ClassReg. "N.B. MoveMb:r:R: does not zero other bits"
  	cogit MoveMb: 7 r: ReceiverResultReg R: ClassReg. "MSB of header"
  	cogit CmpCq: objectMemory numSlotsMask R: ClassReg.
  	jumpSmallSize := cogit JumpLess: 0.
  	cogit MoveMw: -8 r: ReceiverResultReg R: ClassReg. "LSW of overflow size header"
  
  	"dispatch on format in a combination of highest dynamic frequency order first and convenience.
  		  0 = 0 sized objects (UndefinedObject True False et al)
  		  1 = non-indexable objects with inst vars (Point et al)
  		  2 = indexable objects with no inst vars (Array et al)
  		  3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
  		  4 = weak indexable objects with inst vars (WeakArray et al)
  		  5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
  		  6 unused, reserved for exotic pointer objects?
  		  7 Forwarded Object, 1st field is pointer, rest of fields are ignored
  		  8 unused, reserved for exotic non-pointer objects?
  		  9 (?) 64-bit indexable
  		10 - 11 32-bit indexable
  		12 - 15 16-bit indexable
  		16 - 23 byte indexable
  		24 - 31 compiled method"
  	jumpSmallSize jmpTarget:
  					(cogit CmpCq: objectMemory firstByteFormat R: formatReg).
  	jumpIsBytes := cogit JumpGreaterOrEqual: 0.
  					cogit CmpCq: objectMemory arrayFormat R: formatReg.
  	jumpIsArray := cogit JumpZero: 0.
  	jumpNotIndexable := cogit JumpLess: 0.
  					cogit CmpCq: objectMemory weakArrayFormat R: formatReg.
  	jumpHasFixedFields := cogit JumpLessOrEqual: 0.
  					cogit CmpCq: objectMemory firstShortFormat R: formatReg.
  	jumpIsShorts := cogit JumpGreaterOrEqual: 0.
  					cogit CmpCq: objectMemory firstLongFormat R: formatReg.
  	jumpIsWords := cogit JumpGreaterOrEqual: 0.
  	"For now ignore 64-bit indexability."
  	jumpNotIndexable jmpTarget: cogit Label.
  	jumpNotIndexable := cogit Jump: 0.
  
  	jumpIsBytes jmpTarget:
  		(cogit LogicalShiftLeftCq: objectMemory shiftForWord R: ClassReg).
  		cogit AndCq: objectMemory wordSize - 1 R: formatReg.
  		cogit SubR: formatReg R: ClassReg;
+ 		CmpR: Arg1Reg R: ClassReg.
- 		CmpR: Arg0Reg R: ClassReg.
  	jumpBytesOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	cogit AddCq: objectMemory baseHeaderSize R: Arg1Reg.
+ 	cogit MoveXbr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg.
- 	cogit AddCq: objectMemory baseHeaderSize R: Arg0Reg.
- 	cogit MoveXbr: Arg0Reg R: ReceiverResultReg R: ReceiverResultReg.
  	self genConvertIntegerToSmallIntegerInScratchReg: ReceiverResultReg.
  	jumpBytesDone := cogit Jump: 0.
  
  	jumpIsShorts jmpTarget:
  		(cogit LogicalShiftLeftCq: objectMemory shiftForWord - 1 R: ClassReg).
  		cogit AndCq: 1 R: formatReg.
  		cogit SubR: formatReg R: ClassReg;
+ 		CmpR: Arg1Reg R: ClassReg.
- 		CmpR: Arg0Reg R: ClassReg.
  	jumpShortsOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	cogit AddR: Arg1Reg R: ReceiverResultReg.
- 	cogit AddR: Arg0Reg R: ReceiverResultReg.
  	cogit MoveM16: objectMemory baseHeaderSize r: ReceiverResultReg R: ReceiverResultReg.
  	self genConvertIntegerToSmallIntegerInScratchReg: ReceiverResultReg.
  	jumpShortsDone := cogit Jump: 0.
  
  	jumpIsWords jmpTarget:
+ 		(cogit CmpR: Arg1Reg R: ClassReg).
- 		(cogit CmpR: Arg0Reg R: ClassReg).
  	jumpWordsOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg1Reg.
+ 	cogit MoveXwr: Arg1Reg R: ReceiverResultReg R: TempReg.
+ 	cogit SubCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg1Reg.
- 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg0Reg.
- 	cogit MoveXwr: Arg0Reg R: ReceiverResultReg R: TempReg.
- 	cogit SubCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg0Reg.
  	jumpWordTooBig := self jumpNotSmallIntegerUnsignedValueInRegister: TempReg.
  	cogit MoveR: TempReg R: ReceiverResultReg.
  	self genConvertIntegerToSmallIntegerInScratchReg: ReceiverResultReg.
  	jumpWordsDone := cogit Jump: 0.
  
  	jumpHasFixedFields jmpTarget:
  		(cogit AndCq: objectMemory classIndexMask R: TempReg).
  	cogit CmpCq: ClassMethodContextCompactIndex R: TempReg.
  	cogit MoveR: TempReg R: formatReg.
  	cogit CmpCq: ClassMethodContextCompactIndex R: TempReg.
  	jumpIsContext := cogit JumpZero: 0.
  	cogit PushR: ClassReg.
  	self genGetClassObjectOfClassIndex: formatReg into: ClassReg scratchReg: TempReg.
  	self genLoadSlot: InstanceSpecificationIndex sourceReg: ClassReg destReg: formatReg.
  	cogit PopR: ClassReg.
  	self genConvertSmallIntegerToIntegerInScratchReg: formatReg.
  	cogit
  		AndCq: objectMemory fixedFieldsOfClassFormatMask R: formatReg;
  		SubR: formatReg R: ClassReg;
+ 		CmpR: Arg1Reg R: ClassReg.
- 		CmpR: Arg0Reg R: ClassReg.
  	jumpFixedFieldsOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	"index is (formatReg (fixed fields) + Arg1Reg (0-rel index)) * wordSize + baseHeaderSize"
+ 	cogit AddR: formatReg R: Arg1Reg.
+ 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg1Reg.
+ 	cogit MoveXwr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg.
- 	"index is (formatReg (fixed fields) + Arg0Reg (0-rel index)) * wordSize + baseHeaderSize"
- 	cogit AddR: formatReg R: Arg0Reg.
- 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg0Reg.
- 	cogit MoveXwr: Arg0Reg R: ReceiverResultReg R: ReceiverResultReg.
  	jumpFixedFieldsDone := cogit Jump: 0.
  
  	jumpIsArray jmpTarget:
+ 		(cogit CmpR: Arg1Reg R: ClassReg).
- 		(cogit CmpR: Arg0Reg R: ClassReg).
  	jumpArrayOutOfBounds := cogit JumpBelowOrEqual: 0.	
+ 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg1Reg.
+ 	cogit MoveXwr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg.
- 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg0Reg.
- 	cogit MoveXwr: Arg0Reg R: ReceiverResultReg R: ReceiverResultReg.
  
  	jumpFixedFieldsDone jmpTarget:
  	(jumpWordsDone jmpTarget:
  	(jumpShortsDone jmpTarget:
  	(jumpBytesDone jmpTarget:
  		(cogit RetN: retNoffset)))).
  
  	jumpFixedFieldsOutOfBounds jmpTarget:
  	(jumpArrayOutOfBounds jmpTarget:
  	(jumpBytesOutOfBounds jmpTarget:
  	(jumpShortsOutOfBounds jmpTarget:
  	(jumpWordsOutOfBounds jmpTarget:
  	(jumpWordTooBig jmpTarget:
  	(jumpNotIndexable jmpTarget:
+ 	(jumpIsContext jmpTarget:
+ 	(jumpBadIndex jmpTarget:
+ 	(jumpImmediate jmpTarget: cogit Label))))))))).
- 	(jumpIsContext jmpTarget: cogit Label))))))).
  
- 	cogit AddCq: 1 R: Arg0Reg. "0-rel => 1-rel"
- 	self genConvertIntegerToSmallIntegerInScratchReg: Arg0Reg.
- 
- 	(jumpBadIndex jmpTarget: (jumpImmediate jmpTarget: cogit Label)).
- 
  	^0!

Item was changed:
  ----- Method: CogObjectRepresentationFor32BitSpur>>genInnerPrimitiveStringAt: (in category 'primitive generators') -----
  genInnerPrimitiveStringAt: retNoffset
  	"Implement the guts of primitiveStringAt; dispatch on size"
  	| formatReg jumpNotIndexable jumpSmallSize jumpBadIndex done
  	  jumpIsBytes jumpIsShorts jumpIsWords jumpWordTooBig
  	  jumpBytesOutOfBounds jumpShortsOutOfBounds jumpWordsOutOfBounds |
  	<inline: true>
  	"c.f. StackInterpreter>>stSizeOf: SpurMemoryManager>>lengthOf:format: fixedFieldsOf:format:length:"
  	<var: #done type: #'AbstractInstruction *'>
  	<var: #jumpIsBytes type: #'AbstractInstruction *'>
  	<var: #jumpIsShorts type: #'AbstractInstruction *'>
  	<var: #jumpIsWords type: #'AbstractInstruction *'>
  	<var: #jumpBadIndex type: #'AbstractInstruction *'>
  	<var: #jumpSmallSize type: #'AbstractInstruction *'>
  	<var: #jumpWordTooBig type: #'AbstractInstruction *'>
  	<var: #jumpNotIndexable type: #'AbstractInstruction *'>
  	<var: #jumpBytesOutOfBounds type: #'AbstractInstruction *'>
  	<var: #jumpShortsOutOfBounds type: #'AbstractInstruction *'>
  	<var: #jumpWordsOutOfBounds type: #'AbstractInstruction *'>
  
  	cogit MoveR: Arg0Reg R: TempReg.
+ 	cogit MoveR: Arg0Reg R: Arg1Reg.
  	jumpBadIndex := self genJumpNotSmallIntegerInScratchReg: TempReg.
+ 	self genConvertSmallIntegerToIntegerInScratchReg: Arg1Reg.
+ 	cogit SubCq: 1 R: Arg1Reg. "1-rel => 0-rel"
- 	self genConvertSmallIntegerToIntegerInScratchReg: Arg0Reg.
- 	cogit SubCq: 1 R: Arg0Reg. "1-rel => 0-rel"
  
  	formatReg := SendNumArgsReg.
  	cogit
  		MoveMw: 0 r: ReceiverResultReg R: formatReg;				"formatReg := least significant half of self baseHeader: receiver"
  		MoveR: formatReg R: TempReg;
  		LogicalShiftRightCq: objectMemory formatShift R: formatReg;
  		AndCq: objectMemory formatMask R: formatReg.	"formatReg := self formatOfHeader: destReg"
  
  	"get numSlots into ClassReg."
  	cogit MoveCq: 0 R: ClassReg. "N.B. MoveMb:r:R: does not zero other bits"
  	cogit MoveMb: 7 r: ReceiverResultReg R: ClassReg. "MSB of header"
  	cogit CmpCq: objectMemory numSlotsMask R: ClassReg.
  	jumpSmallSize := cogit JumpLess: 0.
  	cogit MoveMw: -8 r: ReceiverResultReg R: ClassReg. "LSW of overflow size header"
  
  	"dispatch on format in a combination of highest dynamic frequency order first and convenience.
  		  0 = 0 sized objects (UndefinedObject True False et al)
  		  1 = non-indexable objects with inst vars (Point et al)
  		  2 = indexable objects with no inst vars (Array et al)
  		  3 = indexable objects with inst vars (MethodContext AdditionalMethodState et al)
  		  4 = weak indexable objects with inst vars (WeakArray et al)
  		  5 = weak non-indexable objects with inst vars (ephemerons) (Ephemeron)
  		  6 unused, reserved for exotic pointer objects?
  		  7 Forwarded Object, 1st field is pointer, rest of fields are ignored
  		  8 unused, reserved for exotic non-pointer objects?
  		  9 (?) 64-bit indexable
  		10 - 11 32-bit indexable
  		12 - 15 16-bit indexable
  		16 - 23 byte indexable
  		24 - 31 compiled method"
  	jumpSmallSize jmpTarget:
  					(cogit CmpCq: objectMemory firstByteFormat R: formatReg).
  	jumpIsBytes := cogit JumpGreaterOrEqual: 0.
  					cogit CmpCq: objectMemory firstShortFormat R: formatReg.
  	jumpIsShorts := cogit JumpGreaterOrEqual: 0.
  					cogit CmpCq: objectMemory firstLongFormat R: formatReg.
  	jumpIsWords := cogit JumpGreaterOrEqual: 0.
  	jumpNotIndexable := cogit Jump: 0.
  
  	jumpIsBytes jmpTarget:
  		(cogit LogicalShiftLeftCq: objectMemory shiftForWord R: ClassReg).
  		cogit AndCq: objectMemory wordSize - 1 R: formatReg.
  		cogit SubR: formatReg R: ClassReg;
+ 		CmpR: Arg1Reg R: ClassReg.
+ 	jumpBytesOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	cogit AddCq: objectMemory baseHeaderSize R: Arg1Reg.
+ 	cogit MoveXbr: Arg1Reg R: ReceiverResultReg R: ReceiverResultReg.
- 		CmpR: Arg0Reg R: ClassReg.
- 	jumpBytesOutOfBounds := cogit JumpAboveOrEqual: 0.
- 	cogit AddCq: objectMemory baseHeaderSize R: Arg0Reg.
- 	cogit MoveXbr: Arg0Reg R: ReceiverResultReg R: ReceiverResultReg.
  	done := cogit Label.
  	self genConvertIntegerToCharacterInScratchReg: ReceiverResultReg.
  	cogit RetN: retNoffset.
  
  	jumpIsShorts jmpTarget:
  		(cogit LogicalShiftLeftCq: objectMemory shiftForWord - 1 R: ClassReg).
  		cogit AndCq: 1 R: formatReg.
  		cogit SubR: formatReg R: ClassReg;
+ 		CmpR: Arg1Reg R: ClassReg.
+ 	jumpShortsOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	cogit AddR: Arg1Reg R: ReceiverResultReg.
- 		CmpR: Arg0Reg R: ClassReg.
- 	jumpShortsOutOfBounds := cogit JumpAboveOrEqual: 0.
- 	cogit AddR: Arg0Reg R: ReceiverResultReg.
  	cogit MoveM16: objectMemory baseHeaderSize r: ReceiverResultReg R: ReceiverResultReg.
  	cogit Jump: done.
  
  	jumpIsWords jmpTarget:
+ 		(cogit CmpR: Arg1Reg R: ClassReg).
+ 	jumpWordsOutOfBounds := cogit JumpBelowOrEqual: 0.
+ 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg1Reg.
+ 	cogit MoveXwr: Arg1Reg R: ReceiverResultReg R: TempReg.
+ 	cogit SubCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg1Reg.
- 		(cogit CmpR: Arg0Reg R: ClassReg).
- 	jumpWordsOutOfBounds := cogit JumpAboveOrEqual: 0.
- 	cogit AddCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg0Reg.
- 	cogit MoveXwr: Arg0Reg R: ReceiverResultReg R: TempReg.
- 	cogit SubCq: objectMemory baseHeaderSize >> objectMemory shiftForWord R: Arg0Reg.
  	jumpWordTooBig := self jumpNotCharacterUnsignedValueInRegister: TempReg.
  	cogit MoveR: TempReg R: ReceiverResultReg.
  	cogit Jump: done.
  
  	jumpBytesOutOfBounds jmpTarget:
  	(jumpShortsOutOfBounds jmpTarget:
  	(jumpWordsOutOfBounds jmpTarget:
  	(jumpWordTooBig jmpTarget:
+ 	(jumpNotIndexable jmpTarget: 
+ 	(jumpBadIndex jmpTarget: cogit Label))))).
- 	(jumpNotIndexable jmpTarget: cogit Label)))).
  
- 	cogit AddCq: 1 R: Arg0Reg. "0-rel => 1-rel"
- 	self genConvertIntegerToSmallIntegerInScratchReg: Arg0Reg.
- 
- 	jumpBadIndex jmpTarget: cogit Label.
- 
  	^0!

Item was changed:
  ----- Method: CogVMSimulator>>utilitiesMenu: (in category 'UI') -----
  utilitiesMenu: aMenuMorph
  	aMenuMorph
  		add: 'toggle transcript' action: #toggleTranscript;
  		add: 'clone VM' action: #cloneSimulation;
  		addLine;
  		add: 'print ext head frame' action: #printExternalHeadFrame;
  		add: 'print int head frame' action: #printHeadFrame;
  		add: 'print mc/cog frame' action: [self printFrame: cogit processor fp WithSP: cogit processor sp];
  		add: 'short print ext frame & callers' action: [self shortPrintFrameAndCallers: framePointer];
  		add: 'short print int frame & callers' action: [self shortPrintFrameAndCallers: localFP];
  		add: 'short print mc/cog frame & callers' action: [self shortPrintFrameAndCallers: cogit processor fp];
  		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: 'long print mc/cog frame & callers' action: [self printFrameAndCallers: cogit processor fp SP: cogit processor sp];
  		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 call stack of frame...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printCallStackFP: fp]];
  		add: 'print all stacks' action: #printAllStacks;
  		add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP.
  											self writeBackHeadFramePointers];
  		add: 'write back mc ptrs' action: [stackPointer := cogit processor sp. framePointer := cogit processor fp. instructionPointer := cogit processor eip.
  											self writeBackHeadFramePointers];
  		addLine;
  		add: 'print registers' action: [cogit processor printRegistersOn: transcript];
  		add: 'print register map' action: [cogit printRegisterMapOn: transcript];
  		add: 'disassemble method/trampoline...' action: [(self promptHex: 'pc') ifNotNil: [:pc| cogit disassembleCodeAt: pc]];
  		add: 'disassemble method/trampoline at pc' action: [cogit disassembleCodeAt: cogit processor pc];
  		add: 'disassemble ext head frame method' action: [cogit disassembleMethod: (self frameMethod: framePointer)];
  		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;
  		add: 'inspect cogit' target: cogit action: #inspect;
  		add: 'inspect method zone' target: cogit methodZone action: #inspect.
  	self isThreadedVM ifTrue:
  		[aMenuMorph add: 'inspect thread manager' target: self threadManager action: #inspect].
  	aMenuMorph
  		addLine;
  		add: 'print cog methods' target: cogMethodZone action: #printCogMethods;
+ 		add: 'print cog methods with prim...' action: [(self promptNum: 'prim index') ifNotNil: [:pix| cogMethodZone printCogMethodsWithPrimitive: pix]];
  		add: 'print trampoline table' target: cogit action: #printTrampolineTable;
  		add: 'print prim trace log' action: #dumpPrimTraceLog;
  		add: 'report recent instructions' target: cogit action: #reportLastNInstructions;
  		add: 'set break pc...' action: [(self promptHex: 'break pc') ifNotNil: [:bpc| cogit breakPC: bpc]];
  		add: (cogit singleStep
  				ifTrue: ['no single step']
  				ifFalse: ['single step'])
  			action: [cogit singleStep: cogit singleStep not];
  		add: (cogit printRegisters
  				ifTrue: ['no print registers each instruction']
  				ifFalse: ['print registers each instruction'])
  			action: [cogit printRegisters: cogit printRegisters not];
  		add: (cogit printInstructions
  				ifTrue: ['no print instructions each instruction']
  				ifFalse: ['print instructions each instruction'])
  			action: [cogit printInstructions: cogit printInstructions not];
  		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: 'set break block...' action: [|s| s := UIManager default request: 'break block'.
  											s notEmpty ifTrue: [self setBreakBlockFromString: s]];
  		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!

Item was changed:
  ----- Method: SpurMemoryManager>>lookupAddress: (in category 'simulation only') -----
  lookupAddress: address
  	"If address appears to be that of a Symbol or a few well-known objects (such as classes) answer it, otherwise answer nil.
  	 For code disassembly"
  	<doNotGenerate>
  	| fmt size string class classSize maybeThisClass classNameIndex thisClassIndex |
+ 	((self addressCouldBeObj: address)
+ 	 and: [(self classIndexOf: address) > 0]) ifFalse:
- 	(self addressCouldBeObj: address) ifFalse:
  		[^address = scavengeThreshold ifTrue:
  			['scavengeThreshold']].
  	address - self baseHeaderSize = hiddenRootsObj ifTrue:
  		[^'(hiddenRootsObj+baseHeaderSize)'].
  	fmt := self formatOf: address.
  	size := self lengthOf: address baseHeader: (self baseHeader: address) format: fmt.
  	size = 0 ifTrue:
  		[^address caseOf: { [nilObj] -> ['nil']. [trueObj] -> ['true']. [falseObj] -> ['false'] } otherwise: []].
  	((fmt between: self firstByteFormat and: self firstCompiledMethodFormat - 1) "indexable byte fields"
  	and: [(size between: 1 and: 64)
  	and: [Scanner isLiteralSymbol: (string := (0 to: size - 1) collect: [:i| Character value: (self fetchByte: i ofObject: address)])]]) ifTrue:
  		[^'#', (ByteString withAll: string)].
  	class := self fetchClassOfNonImm: address.
  	(class isNil or: [class = nilObj]) ifTrue:
  		[^nil].
  	"address is either a class or a metaclass, or an instance of a class or invalid.  determine which."
  	classNameIndex := coInterpreter classNameIndex.
  	thisClassIndex := coInterpreter thisClassIndex.
  	((classSize := self numSlotsOf: class) <= (classNameIndex max: thisClassIndex)
  	 or: [classSize > 255]) ifTrue:
  		[^nil].
  	"Address could be a class or a metaclass"
  	(fmt = 1 and: [size >= classNameIndex]) ifTrue:
  		["Is address a class? If so class's thisClass is address."
  		 (self lookupAddress: (self fetchPointer: classNameIndex ofObject: address)) ifNotNil:
  			[:maybeClassName|
  			(self fetchPointer: thisClassIndex ofObject: class) = address ifTrue:
  				[^maybeClassName allButFirst]].
  		"Is address a Metaclass?  If so class's name is Metaclass and address's thisClass holds the class name"
  		((self isBytes: (self fetchPointer: classNameIndex ofObject: class))
  		 and: [(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) = '#Metaclass'
  		 and: [size >= thisClassIndex]]) ifTrue:
  			[maybeThisClass := self fetchPointer: thisClassIndex ofObject: address.
  			(self lookupAddress: (self fetchPointer: classNameIndex ofObject: maybeThisClass)) ifNotNil:
  				[:maybeThisClassName| ^maybeThisClassName allButFirst, ' class']]].
  	^(self lookupAddress: (self fetchPointer: classNameIndex ofObject: class)) ifNotNil:
  		[:maybeClassName| 'a(n) ', maybeClassName allButFirst]!

Item was changed:
  ----- Method: StackInterpreterSimulator>>utilitiesMenu: (in category 'UI') -----
  utilitiesMenu: aMenuMorph
  	aMenuMorph
  		add: 'toggle transcript' action: #toggleTranscript;
  		add: 'clone VM' action: #cloneSimulation;
  		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 call stack of frame...' action: [(self promptHex: 'frame') ifNotNil: [:fp| self printCallStackFP: fp]];
  		add: 'print all stacks' action: #printAllStacks;
  		add: 'write back local ptrs' action: [stackPointer := localSP. framePointer := localFP. instructionPointer := localIP.
  											self writeBackHeadFramePointers];
  		add: 'print prim trace log' action: #dumpPrimTraceLog;
  		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!

Item was added:
+ ----- Method: VMClass>>promptNum: (in category 'simulation support') -----
+ promptNum: string
+ 	<doNotGenerate>
+ 	| s |
+ 	s := UIManager default request: string, ' (dec)'.
+ 	s := s withBlanksTrimmed.
+ 	^s notEmpty ifTrue:
+ 		[Number readFrom: s readStream]!



More information about the Vm-dev mailing list