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@0 corner: 1@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@0.8 corner: 0.7@1). + window addMorph: (PluggableTextMorph on: self - theWindow addMorph: (PluggableTextMorph on: self text: #byteCountText accept: nil readSelection: nil menu: #utilitiesMenu:) hideScrollBarsIndefinitely frame: (0.7@0.8 corner: 1@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@window labelHeight) + * (1@(1/0.8))) rounded. + ^window! - + (0@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@0 corner: 1@0.8).
transcript := TranscriptStream on: (String new: 10000). 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) hideScrollBarsIndefinitely frame: (0.7@0.8 corner: 1@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@0 corner: 1@0.8).
transcript := TranscriptStream on: (String new: 10000). 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. + ^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@0 corner: 1@0.8).
transcript := TranscriptStream on: (String new: 10000). 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. + ^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!
vm-dev@lists.squeakfoundation.org