[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