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

commits at source.squeak.org commits at source.squeak.org
Mon Sep 23 21:41:24 UTC 2013


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

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

Name: VMMaker.oscog-eem.406
Author: eem
Time: 23 September 2013, 2:38:38.527 pm
UUID: fa4c2477-036c-424e-9c73-f4e4c8a9bd3f
Ancestors: VMMaker.oscog-eem.405

Fix the scavengeLoop for the mapInterpreterOops call.  mIO can
cause objects to be copied and forwarded /and/ remembered (if
tenured) so the termination condition is nothing forwarded /and/
northing remembered, hence previousRememberedSetSize must be
recorded before sending mIO.

Fix objectBytesForSlots:; ot forgot to include the forwarding slot in
empty objects.

Fix allocateOldSpaceChunkOfBytes: to use freeListsMask (<= not >=).

Fix instanceAfter: (use of objOop after the fact).

refactor objectAfter:limit:, it differs slightly between 32 & 64 bits.

Make printNameOfClass:count: accet a nil class (as answered by
classAtIndex:).

Simulator:
Implement cloneSimulation for debugging.  Allows e.g. rerunning the
same scavenge in the clone for repeatibility.

Simplify the window quitBlocks now I know about containingWindow.

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

Item was changed:
  ----- Method: CogVMSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  	"Open a morphic view on this simulation."
+ 	| localImageName borderWidth window |
- 	| localImageName borderWidth theWindow |
  	localImageName := imageName
  							ifNotNil: [FileDirectory default localNameFor: imageName]
  							ifNil: [' synthetic image'].
+ 	window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
- 	theWindow := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  
+ 	window addMorph: (displayView := ImageMorph new image: displayForm)
- 	theWindow addMorph: (displayView := ImageMorph new image: displayForm)
  		frame: (0 at 0 corner: 1 at 0.8).
  
  	transcript := TranscriptStream on: (String new: 10000).
+ 	window addMorph: (PluggableTextMorph
- 	theWindow addMorph: (PluggableTextMorph
  							on: transcript text: nil accept: nil
  							readSelection: nil menu: #codePaneMenu:shifted:)
  			frame: (0 at 0.8 corner: 0.7 at 1).
+ 	window addMorph: (PluggableTextMorph on: self
- 	theWindow addMorph: (PluggableTextMorph on: self
  						text: #byteCountText accept: nil
  						readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  			frame: (0.7 at 0.8 corner: 1 at 1).
  
  	borderWidth := [SystemWindow borderWidth] "Squeak 4.1"
  						on: MessageNotUnderstood
  						do: [:ex| 0]. "3.8"
+ 	borderWidth := borderWidth + window borderWidth.
+ 	window openInWorldExtent: (self desiredDisplayExtent
- 	borderWidth := borderWidth + theWindow borderWidth.
- 	theWindow openInWorldExtent: (self desiredDisplayExtent
  								+ (2 * borderWidth)
+ 								+ (0 at window labelHeight)
+ 								* (1@(1/0.8))) rounded.
+ 	^window!
- 								+ (0 at theWindow labelHeight)
- 								* (1@(1/0.8))) rounded!

Item was changed:
  ----- Method: CogVMSimulator>>run (in category 'testing') -----
  run
  	"Just run"
+ 	quitBlock := [displayView ifNotNil:
+ 				   [displayView containingWindow ifNotNil:
+ 					[:topWindow|
+ 					((World submorphs includes: topWindow)
+ 					 and: [UIManager default confirm: 'close?']) ifTrue:
+ 						[topWindow delete]]].
- 	quitBlock := [| topWindow |
- 				  
- 				   (displayView notNil
- 				   and: [topWindow := displayView outermostMorphThat:
- 									[:m| m isSystemWindow and: [World submorphs includes: m]].
- 						topWindow notNil
- 				   and: [UIManager default confirm: 'close?']]) ifTrue:
- 					[topWindow delete].
  				  ^self].
  	self initStackPages.
  	self loadInitialContext.
  	self initialEnterSmalltalkExecutive!

Item was changed:
  ----- Method: CogVMSimulator>>runWithBreakCount: (in category 'testing') -----
  runWithBreakCount: theBreakCount
  	"Just run, halting when byteCount is reached"
+ 	quitBlock := [displayView ifNotNil:
+ 				   [displayView containingWindow ifNotNil:
+ 					[:topWindow|
+ 					((World submorphs includes: topWindow)
+ 					 and: [UIManager default confirm: 'close?']) ifTrue:
+ 						[topWindow delete]]].
- 	quitBlock := [(displayView notNil
- 				   and: [UIManager default confirm: 'close?']) ifTrue:
- 					[(displayView outermostMorphThat: [:m| m isSystemWindow]) ifNotNil:
- 						[:topWindow| topWindow delete]].
  				  ^self].
  	breakCount := theBreakCount.
  	self initStackPages.
  	self loadInitialContext.
  	self initialEnterSmalltalkExecutive!

Item was changed:
  ----- Method: InterpreterSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  	"Open a morphic view on this simulation."
  	| window localImageName |
  	localImageName := imageName
  							ifNotNil: [FileDirectory default localNameFor: imageName]
  							ifNil: [' synthetic image'].
  	window := (SystemWindow labelled: 'Simulation of ' , localImageName) model: self.
  
  	window addMorph: (displayView := ImageMorph new image: displayForm)
  		frame: (0 at 0 corner: 1 at 0.8).
  
  	transcript := TranscriptStream on: (String new: 10000).
  	window addMorph: (PluggableTextMorph on: transcript text: nil accept: nil
  			readSelection: nil menu: #codePaneMenu:shifted:)
  		frame: (0 at 0.8 corner: 0.7 at 1).
  
  	window addMorph: (PluggableTextMorph on: self
  						text: #byteCountText accept: nil) hideScrollBarsIndefinitely
  		frame: (0.7 at 0.8 corner: 1 at 1).
  
+ 	window openInWorld.
+ 	^window!
- 	window openInWorld!

Item was changed:
  ----- Method: NewspeakInterpreterSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  	"Open a morphic view on this simulation."
  	| window localImageName |
  	localImageName := imageName
  							ifNotNil: [FileDirectory default localNameFor: imageName]
  							ifNil: [' synthetic image'].
  	window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  
  	window addMorph: (displayView := ImageMorph new image: displayForm)
  		frame: (0 at 0 corner: 1 at 0.8).
  
  	transcript := TranscriptStream on: (String new: 10000).
  	window addMorph: (PluggableTextMorph
  							on: transcript text: nil accept: nil
  							readSelection: nil menu: #codePaneMenu:shifted:)
  			frame: (0 at 0.8 corner: 0.7 at 1).
  
  	window addMorph: (PluggableTextMorph on: self
  						text: #byteCountText accept: nil
  						readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  			frame: (0.7 at 0.8 corner: 1 at 1).
  
  	window openInWorldExtent: (self desiredDisplayExtent
  								+ (2 * window borderWidth)
  								+ (0 at window labelHeight)
+ 								* (1@(1/0.8))) rounded.
+ 	^window!
- 								* (1@(1/0.8))) rounded!

Item was changed:
  ----- Method: Spur32BitMMLESimulator>>longAt:put: (in category 'memory access') -----
  longAt: byteAddress put: a32BitValue
  	"Note: Adjusted for Smalltalk's 1-based array indexing."
+ 	"(byteAddress = 16r11D8240 and: [a32BitValue = 16r1D8368]) ifTrue:
- 	"(byteAddress = 16r120DBDC and: [a32BitValue = 16r16000000]) ifTrue:
  		[self halt]."
  	byteAddress \\ 4 ~= 0 ifTrue: [self unalignedAccessError].
  	^memory at: byteAddress // 4 + 1 put: a32BitValue!

Item was changed:
  ----- Method: Spur32BitMMLESimulator>>longLongAt:put: (in category 'memory access') -----
  longLongAt: byteAddress put: a64BitValue
  	"memory is a Bitmap, a 32-bit indexable array of bits"
  	byteAddress \\ 8 ~= 0 ifTrue: [self unalignedAccessError].
+ 	"(byteAddress = 16r11D8240 and: [(a64BitValue bitAnd: 16rffffffff) = 16r1D8368]) ifTrue:
+ 		[self halt]."
- 	"((byteAddress = 16r120DBDC or: [byteAddress = 16r120DBD8])
- 	 and: [a64BitValue >> 32 = 16r16000000
- 		or: [(a64BitValue bitAnd: 16rffffffff) = 16r16000000]]) ifTrue:
- 			[self halt]."
  	memory
  		at: byteAddress // 4 + 1 put: (a64BitValue bitAnd: 16rffffffff);
  		at: byteAddress // 4 + 2 put: a64BitValue >> 32.
  	^a64BitValue!

Item was added:
+ ----- Method: Spur32BitMMLESimulator>>stObject:at:put: (in category 'simulation only') -----
+ stObject: objOop at: indexOop put: valueOop
+ 	"hack around the CoInterpreter/ObjectMemory split refactoring"
+ 	^coInterpreter stObject: objOop at: indexOop put: valueOop!

Item was added:
+ ----- Method: Spur32BitMemoryManager>>objectAfter:limit: (in category 'object enumeration') -----
+ objectAfter: objOop limit: limit
+ 	"Object parsing.
+ 	1. all objects have at least a word following the header, for a forwarding pointer.
+ 	2. objects with an overflow size have a preceeing word with a saturated numSlots.  If the word
+ 	   following an object doesn't have a saturated numSlots field it must be a single-header object.
+ 	   If the word following does have a saturated numSlots it must be the overflow size word."
+ 	| followingWordAddress followingWord |
+ 	followingWordAddress := self addressAfter: objOop.
+ 	followingWordAddress >= limit ifTrue:
+ 		[^limit].
+ 	self flag: #endianness.
+ 	followingWord := self longAt: followingWordAddress + 4.
+ 	^followingWord >> self numSlotsHalfShift = self numSlotsMask
+ 		ifTrue: [followingWordAddress + self baseHeaderSize]
+ 		ifFalse: [followingWordAddress]!

Item was changed:
  ----- Method: Spur32BitMemoryManager>>objectBytesForSlots: (in category 'object enumeration') -----
  objectBytesForSlots: numSlots
  	"Answer the total number of bytes in an object with the given
  	 number of slots, including header and possible overflow size header."
+ 	^(numSlots = 0
+ 		ifTrue: [self allocationUnit] "always at least one slot for forwarding pointer"
+ 		ifFalse: [numSlots + (numSlots bitAnd: 1) << self shiftForWord])
- 	^numSlots + (numSlots bitAnd: 1) << self shiftForWord
  	+ (numSlots >= self numSlotsMask
  		ifTrue: [self baseHeaderSize + self baseHeaderSize]
  		ifFalse: [self baseHeaderSize])!

Item was added:
+ ----- Method: Spur64BitMemoryManager>>objectAfter:limit: (in category 'object enumeration') -----
+ objectAfter: objOop limit: limit
+ 	"Object parsing.
+ 	1. all objects have at least a word following the header, for a forwarding pointer.
+ 	2. objects with an overflow size have a preceeing word with a saturated numSlots.  If the word
+ 	   following an object doesn't have a saturated numSlots field it must be a single-header object.
+ 	   If the word following does have a saturated numSlots it must be the overflow size word."
+ 	| followingWordAddress followingWord |
+ 	followingWordAddress := self addressAfter: objOop.
+ 	followingWordAddress >= limit ifTrue:
+ 		[^limit].
+ 	self flag: #endianness.
+ 	followingWord := self longAt: followingWordAddress.
+ 	^followingWord >> self numSlotsFullShift = self numSlotsMask
+ 		ifTrue: [followingWordAddress + self baseHeaderSize]
+ 		ifFalse: [followingWordAddress]!

Item was changed:
  ----- Method: Spur64BitMemoryManager>>objectBytesForSlots: (in category 'object enumeration') -----
  objectBytesForSlots: numSlots
  	"Answer the total number of bytes in an object with the given
  	 number of slots, including header and possible overflow size header."
+ 	^(numSlots max: 1) << self shiftForWord
- 	^numSlots << self shiftForWord
  	+ (numSlots >= self numSlotsMask
  		ifTrue: [self baseHeaderSize + self baseHeaderSize]
  		ifFalse: [self baseHeaderSize])!

Item was changed:
  ----- Method: SpurGenerationScavenger>>scavengeLoop (in category 'scavenger') -----
  scavengeLoop
  	"This is the inner loop of the main routine, scavenge.  It first scavenges the new objects immediately
  	 reachable from old ones. Then it scavenges those that are transitively reachable.  If this results in a
  	 promotion, the promotee gets remembered, and it first scavenges objects adjacent to the promotee,
  	 then scavenges the ones reachable from the promoted.  This loop continues until no more reachable
  	 objects are left.  At that point, pastSurvivorSpace is exchanged with futureSurvivorSpace.
  
  	 Notice that each pointer in a live object is inspected once and only once.  The previousRememberedSetSize
  	 and previousFutureSurvivorSpaceLimit variables ensure that no object is scanned twice, as well as
  	 detecting closure.  If this were not true, some pointers might get forwarded twice."
  
  	| firstTime previousRememberedSetSize previousFutureSurvivorStart |
  	self assert: futureSurvivorStart = futureSpace start. "future space should be empty at the start"
  	firstTime := true.
  	previousRememberedSetSize := 0.
  	previousFutureSurvivorStart := futureSurvivorStart.
  	[self scavengeRememberedSetStartingAt: previousRememberedSetSize.
+ 	 previousRememberedSetSize := rememberedSetSize.
  	 firstTime ifTrue:
  		[coInterpreter mapInterpreterOops.
  		 firstTime := false].
+ 	 "nothing more copied and forwarded (or remembered by mapInterpreterOops)
+ 	  to scavenge so scavenge is done."
+ 	 (previousRememberedSetSize = rememberedSetSize
+ 	  and: [previousFutureSurvivorStart = futureSurvivorStart]) ifTrue:
- 	 "northing more copied and forwarded to scavenge so scavenge is done."
- 	 previousFutureSurvivorStart = futureSurvivorStart ifTrue:
  		[^self].
- 	 previousRememberedSetSize := rememberedSetSize.
  
  	 self scavengeFutureSurvivorSpaceStartingAt: previousFutureSurvivorStart.
  	 "no more roots created to scavenge, so scavenge is done."
  	 previousRememberedSetSize = rememberedSetSize ifTrue:
  		[^self].
  
  	 previousFutureSurvivorStart := futureSurvivorStart] repeat!

Item was changed:
  ----- Method: SpurGenerationScavengerSimulator>>copyAndForward: (in category 'scavenger') -----
  copyAndForward: survivor
  	| newLocation |
+ 	true ifTrue: [^super copyAndForward: survivor.].
+ 	"(#(16r13BC78 16r13BD68 16r1ED780 16r1FC558) includes: survivor) ifTrue: [self halt]."
- 	survivor = 16r19BC60 ifTrue: [self halt].
  	newLocation := super copyAndForward: survivor.
  	comeFroms at: newLocation put: survivor.
+ 	"((manager isContextNonImm: newLocation)
+ 	 and: [#(16r11D6988 16r11D6A48 16r11D6AC0 16r11D6B80) includes: newLocation]) ifTrue:
+ 		[self halt]."
  	^newLocation!

Item was changed:
  ----- Method: SpurMemoryManager>>allocateOldSpaceChunkOfBytes: (in category 'free space') -----
  allocateOldSpaceChunkOfBytes: chunkBytes
  	"Answer a chunk of oldSpace from the free lists, if available,
  	 otherwise answer nil.  N.B.  the chunk is simply a pointer, it has
  	 no valid header.  The caller *must* fill in the header correctly."
  	| index chunk nextIndex nodeBytes parent child smaller larger |
  	totalFreeOldSpace := totalFreeOldSpace - chunkBytes. "be optimistic (& don't wait for the write)"
  	index := chunkBytes / self allocationUnit.
+ 	(index < NumFreeLists and: [1 << index <= freeListsMask]) ifTrue:
- 	(index < NumFreeLists and: [1 << index >= freeListsMask]) ifTrue:
  		[(chunk := freeLists at: index) ~= 0 ifTrue:
  			[self assert: chunk = (self startOfObject: chunk).
  			^self unlinkFreeChunk: chunk atIndex: index].
  		 "first search for free chunks of a multiple of chunkBytes in size"
  		 nextIndex := index.
+ 		 [1 << index <= freeListsMask
- 		 [1 << index >= freeListsMask
  		  and: [(nextIndex := nextIndex + index) < NumFreeLists]] whileTrue:
  			[((freeListsMask anyMask: 1 << index)
  			 and: [(chunk := freeLists at: index) ~= 0]) ifTrue:
  				[self assert: chunk = (self startOfObject: chunk).
  				 self unlinkFreeChunk: chunk atIndex: index.
  				 self assert: (self bytesInObject: chunk) = index * self allocationUnit.
  				 self freeChunkWithBytes: index * self allocationUnit - chunkBytes
  					at: (self startOfObject: chunk) + chunkBytes.
  				^chunk]].
  		 "now get desperate and use the first that'll fit"
  		 nextIndex := index.
  		 [1 << index >= freeListsMask
  		  and: [(nextIndex := nextIndex + 1) < NumFreeLists]] whileTrue:
  			[(freeListsMask anyMask: 1 << index) ifTrue:
  				[(chunk := freeLists at: index) ~= 0 ifTrue:
  					[self assert: chunk = (self startOfObject: chunk).
  					 self unlinkFreeChunk: chunk atIndex: index.
  					 self assert: (self bytesInObject: chunk) = index * self allocationUnit.
  					 self freeChunkWithBytes: index * self allocationUnit - chunkBytes
  						at: (self startOfObject: chunk) + chunkBytes.
  					^chunk].
  				 freeListsMask := freeListsMask - (1 << index)]]].
  
  	"Large chunk, or no space on small free lists.  Search the large chunk list.
  	 Large chunk list organized as a tree, each node of which is a list of chunks
  	 of the same size. Beneath the node are smaller and larger blocks."
  	parent := 0.
  	child := freeLists at: 0.
  	[child ~= 0] whileTrue:
  		[nodeBytes := self bytesInObject: child.
  		 parent := child.
  		 nodeBytes = chunkBytes
  			ifTrue: "size match; try to remove from list at node."
  				[chunk := self fetchPointer: self freeChunkNextIndex
  								ofFreeChunk: child.
  				 chunk ~= 0 ifTrue:
  					[self storePointer: self freeChunkNextIndex
  						ofFreeChunk: child
  						withValue: (self fetchPointer: self freeChunkNextIndex
  										ofFreeChunk: chunk).
  					 ^self startOfObject: chunk].
  				 child := 0] "break out of loop to remove interior node"
  			ifFalse:"walk down the tree"
  				[child := self fetchPointer: (nodeBytes > chunkBytes
  												ifTrue: [self freeChunkSmallerIndex]
  												ifFalse: [self freeChunkLargerIndex])
  								ofFreeChunk: child]].
  	parent = 0 ifTrue:
  		[totalFreeOldSpace := totalFreeOldSpace + chunkBytes. "optimism was unfounded"
  		 self halt].
  
  	"self printFreeChunk: parent"
  	self assert: (self bytesInObject: parent) = nodeBytes.
  	"attempt to remove from list"
  	chunk := self fetchPointer: self freeChunkNextIndex
  					ofFreeChunk: parent.
  	chunk ~= 0 ifTrue:
  		[self storePointer: self freeChunkNextIndex
  			ofFreeChunk: parent
  			withValue: (self fetchPointer: self freeChunkNextIndex
  							ofFreeChunk: chunk).
  		 chunkBytes ~= nodeBytes ifTrue:
  			[self freeChunkWithBytes: nodeBytes - chunkBytes
  					at: (self startOfObject: chunk) + chunkBytes].
  		 ^self startOfObject: chunk].
  	"no list; remove an interior node"
  	chunk := parent.
  	parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: chunk.
  	"no parent; stitch the subnodes back into the root"
  	parent = 0 ifTrue:
  		[smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: chunk.
  		 larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: chunk.
  		 smaller = 0
  			ifTrue: [freeLists at: 0 put: larger]
  			ifFalse:
  				[freeLists at: 0 put: smaller.
  				 larger ~= 0 ifTrue:
  					[self addFreeSubTree: larger]].
  		"coInterpreter transcript ensureCr.
  		 coInterpreter print: 'new free tree root '.
  		 (freeLists at: 0) = 0 ifTrue: [coInterpreter print: '0'] ifFalse: [self printFreeChunk: (freeLists at: 0)].
  		 coInterpreter cr."
  		 chunkBytes ~= nodeBytes ifTrue:
  			[self freeChunkWithBytes: nodeBytes - chunkBytes
  					at: (self startOfObject: chunk) + chunkBytes].
  		 ^self startOfObject: chunk].
  	"remove node from tree; reorder tree simply.  two cases (which have mirrors, for four total):
  	 case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
  			___				  ___
  			| P |				  | P |
  		    _/_				_/_
  		    | N |		=>		| S |
  		 _/_
  		 | S |"
  	self halt.
  	"case 2: interior node has two children, , P = parent, N = node, L = smaller, left subtree, R = larger, right subtree.
  	 add the left subtree to the bottom left of the right subtree (mirrored for large vs small) 
  			___				  ___
  			| P |				  | P |
  		    _/_				_/_
  		    | N |		=>		| R |
  		 _/_  _\_		    _/_
  		 | L | | R |		    | L |"
  	self halt!

Item was changed:
  ----- Method: SpurMemoryManager>>instanceAfter: (in category 'object enumeration') -----
  instanceAfter: objOop
  	| actualObj classIndex |
  	actualObj := objOop.
  	classIndex := self classIndexOf: objOop.
+ 
  	(self isInEden: objOop) ifTrue:
+ 		[[actualObj := self objectAfter: actualObj limit: freeStart.
+ 		  actualObj < freeStart] whileTrue:
- 		[actualObj := self objectAfter: actualObj limit: freeStart.
- 		[objOop < freeStart] whileTrue:
  			[classIndex = (self classIndexOf: actualObj) ifTrue:
+ 				[^actualObj]].
- 				[^actualObj].
- 		 actualObj := self objectAfter: objOop limit: freeStart].
  		 actualObj := pastSpaceStart > scavenger pastSpace start
  						ifTrue: [self objectStartingAt: scavenger pastSpace start]
  						ifFalse: [nilObj]].
+ 
  	(self isInSurvivorSpace: actualObj) ifTrue:
+ 		[[actualObj := self objectAfter: actualObj limit: pastSpaceStart.
+ 		  actualObj < pastSpaceStart] whileTrue:
- 		[actualObj := self objectAfter: actualObj limit: pastSpaceStart.
- 		[objOop < pastSpaceStart] whileTrue:
  			[classIndex = (self classIndexOf: actualObj) ifTrue:
+ 				[^actualObj]].
- 				[^actualObj].
- 		 actualObj := self objectAfter: objOop limit: pastSpaceStart].
  		 actualObj := nilObj].
+ 
+ 	[actualObj := self objectAfter: actualObj limit: freeOldSpaceStart.
+ 	 actualObj < freeOldSpaceStart] whileTrue:
- 	actualObj := self objectAfter: actualObj limit: freeOldSpaceStart.
- 	[objOop < freeOldSpaceStart] whileTrue:
  		[classIndex = (self classIndexOf: actualObj) ifTrue:
+ 			[^actualObj]].
- 			[^actualObj].
- 		 actualObj := self objectAfter: objOop limit: freeOldSpaceStart].
  	^nil!

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:
+ 		isNormalized:
+ 		primDigitDiv:negative:) includes: sel) ifFalse:
- 		signed32BitValueOf:) includes: sel) ifFalse:
  		[self halt].
  	^(oop bitAnd: 1) ~= 0!

Item was changed:
  ----- Method: SpurMemoryManager>>objectAfter:limit: (in category 'object enumeration') -----
  objectAfter: objOop limit: limit
  	"Object parsing.
  	1. all objects have at least a word following the header, for a forwarding pointer.
  	2. objects with an overflow size have a preceeing word with a saturated numSlots.  If the word
  	   following an object doesn't have a saturated numSlots field it must be a single-header object.
  	   If the word following does have a saturated numSlots it must be the overflow size word."
+ 	^self subclassResponsibility!
- 	| followingWordAddress followingWord |
- 	followingWordAddress := self addressAfter: objOop.
- 	followingWordAddress >= limit ifTrue:
- 		[^limit].
- 	self flag: #endianness.
- 	followingWord := self longAt: followingWordAddress + 4.
- 	^followingWord >> self numSlotsHalfShift = self numSlotsMask
- 		ifTrue: [followingWordAddress + self baseHeaderSize]
- 		ifFalse: [followingWordAddress]!

Item was changed:
  ----- Method: StackInterpreter>>printNameOfClass:count: (in category 'debug printing') -----
  printNameOfClass: classOop count: cnt
  	"Details: The count argument is used to avoid a possible infinite recursion if classOop is a corrupted object."
  	<inline: false>
+ 	(classOop isNil or: [classOop = 0 or: [cnt <= 0]]) ifTrue: [^self print: 'bad class'].
- 	(classOop = 0 or: [cnt <= 0]) ifTrue: [^self print: 'bad class'].
  	((objectMemory sizeBitsOf: classOop) = metaclassSizeBits
  	  and: [metaclassSizeBits > (thisClassIndex * BytesPerOop)])	"(Metaclass instSize * 4)"
  		ifTrue: [self printNameOfClass: (objectMemory fetchPointer: thisClassIndex ofObject: classOop) count: cnt - 1.
  				self print: ' class']
  		ifFalse: [self printStringOf: (objectMemory fetchPointer: classNameIndex ofObject: classOop)]!

Item was added:
+ ----- Method: StackInterpreterSimulator>>cloneSimulation (in category 'debug support') -----
+ cloneSimulation
+ 	| savedDisplayView savedDisplayForm savedQuitBlock savedTranscript |
+ 	savedDisplayView := displayView. displayView := nil.
+ 	savedDisplayForm := displayForm. displayForm = nil.
+ 	savedQuitBlock := quitBlock. quitBlock := nil.
+ 	savedTranscript := transcript. transcript := nil.
+ 
+ 	[| clone window |
+ 	 clone := self veryDeepCopy.
+ 	 window := clone openAsMorph.
+ 	 window setLabel: 'Clone of ', (savedDisplayView containingWindow label allButFirst: 'Simulation of ' size)]
+ 		ensure:
+ 			[displayView := savedDisplayView.
+ 			 displayForm = savedDisplayForm.
+ 			 quitBlock := savedQuitBlock.
+ 			 transcript := savedTranscript]!

Item was changed:
  ----- Method: StackInterpreterSimulator>>openAsMorph (in category 'UI') -----
  openAsMorph
  	"Open a morphic view on this simulation."
  	| window localImageName |
  	localImageName := imageName
  							ifNotNil: [FileDirectory default localNameFor: imageName]
  							ifNil: [' synthetic image'].
  	window := (SystemWindow labelled: 'Simulation of ', localImageName) model: self.
  
  	window addMorph: (displayView := ImageMorph new image: displayForm)
  		frame: (0 at 0 corner: 1 at 0.8).
  
  	transcript := TranscriptStream on: (String new: 10000).
  	window addMorph: (PluggableTextMorph
  							on: transcript text: nil accept: nil
  							readSelection: nil menu: #codePaneMenu:shifted:)
  			frame: (0 at 0.8 corner: 0.7 at 1).
  
  	window addMorph: (PluggableTextMorph on: self
  						text: #byteCountText accept: nil
  						readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely
  			frame: (0.7 at 0.8 corner: 1 at 1).
  
  	window openInWorldExtent: (self desiredDisplayExtent
  								+ (2 * window borderWidth)
  								+ (0 at window labelHeight)
+ 								* (1@(1/0.8))) rounded.
+ 	^window!
- 								* (1@(1/0.8))) rounded!

Item was changed:
  ----- Method: StackInterpreterSimulator>>run (in category 'testing') -----
  run
  	"Just run"
+ 	quitBlock := [displayView ifNotNil:
+ 				   [displayView containingWindow ifNotNil:
+ 					[:topWindow|
+ 					((World submorphs includes: topWindow)
+ 					 and: [UIManager default confirm: 'close?']) ifTrue:
+ 						[topWindow delete]]].
- 	quitBlock := [| topWindow |
- 				  
- 				   (displayView notNil
- 				   and: [topWindow := displayView outermostMorphThat:
- 									[:m| m isSystemWindow and: [World submorphs includes: m]].
- 						topWindow notNil
- 				   and: [UIManager default confirm: 'close?']]) ifTrue:
- 					[topWindow delete].
  				  ^self].
  	self initStackPages.
  	self loadInitialContext.
  	self internalizeIPandSP.
  	self fetchNextBytecode.
  	[true] whileTrue:
  		[self assertValidExecutionPointers.
  		 atEachStepBlock value. "N.B. may be nil"
  		 self dispatchOn: currentBytecode in: BytecodeTable.
  		 self incrementByteCount].
  	localIP := localIP - 1.
  	"undo the pre-increment of IP before returning"
  	self externalizeIPandSP!

Item was changed:
  ----- Method: StackInterpreterSimulator>>runWithBreakCount: (in category 'testing') -----
  runWithBreakCount: theBreakCount
  	"Just run, halting when byteCount is reached"
+ 	quitBlock := [displayView ifNotNil:
+ 				   [displayView containingWindow ifNotNil:
+ 					[:topWindow|
+ 					((World submorphs includes: topWindow)
+ 					 and: [UIManager default confirm: 'close?']) ifTrue:
+ 						[topWindow delete]]].
- 	quitBlock := [| topWindow |
- 				  
- 				   (displayView notNil
- 				   and: [topWindow := displayView outermostMorphThat:
- 									[:m| m isSystemWindow and: [World submorphs includes: m]].
- 						topWindow notNil
- 				   and: [UIManager default confirm: 'close?']]) ifTrue:
- 					[topWindow delete].
  				  ^self].
  	breakCount := theBreakCount.
  	self initStackPages.
  	self loadInitialContext.
  	self internalizeIPandSP.
  	self fetchNextBytecode.
  	[true] whileTrue:
  		[self assertValidExecutionPointers.
  		 self dispatchOn: currentBytecode in: BytecodeTable.
  		 self incrementByteCount].
  	localIP := localIP - 1.
  	"undo the pre-increment of IP before returning"
  	self externalizeIPandSP!

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 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