[Vm-dev] VM Maker: VMMaker.oscog-eem.504.mcz
commits at source.squeak.org
commits at source.squeak.org
Sat Nov 9 21:38:40 UTC 2013
Eliot Miranda uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog-eem.504.mcz
==================== Summary ====================
Name: VMMaker.oscog-eem.504
Author: eem
Time: 9 November 2013, 1:35:15.465 pm
UUID: 0c8604fd-5734-4097-a9a8-68958c3c506f
Ancestors: VMMaker.oscog-eem.503
Spur:
Fix checkStackIntegrity to check that frame contexts are married to
their frames. Add an assert to mapStackPages to check that frame
contexts are married to their frames post remap.
Refactor runLeakCheckerForFullGC: into checkHeapIntegrity: &
runLeakCheckerForFullGC:excludeUnmarkedNewSpaceObjs: to allow
leak-checking after mark phase when in news space only marked
objs should be scanned for refs.
Fix nasty boundary condition where chunks of size 1038 bytes in
32-bits, or 2048 bytes in 64-bits require a double header even
though their number of slots is < numSlotsMask. Also requires that
addFreeSubTree: uses bytesInObject: not numSlotsOfAny:. So use
bytesInObject: in sizeOfFree: also.
Fix resetAsEmpty to reset first, and use it in
fillHighestObjectsWithMovableObjectsFrom:upTo:.
Bump size of remembered table to 64k emporarily to get shootout
tests to run. The remembered table needs to move to the heap and
be growable.
Call growOldSpaceByAtLeast: when copyToOldSpace: fails to be given
old space.
Fix slip in [check]OkayOop: checking that double-header objs have
a saturated slot count in the overflow word.
Second pass in eliminateAndFreeForwarders needs to use
allOldSpaceEntitiesFrom:do:.
Check for young obj in remapObj: needs to apply to all args, not
just forwarded ones.
Fix assert in storePointer:ofFreeChunk:withValue:. Consequently,
add and use storePointerNoAssert:ofFreeChunk:withValue: in
swizzleFieldsOfFreeChunk: to avoid assert-fails on image load.
Fix slip in unlinkSolitaryFreeTreeNode: when removing last node.
Both isWidowedContext: & checkIsStillMarriedContext:currentFP:
must cope with forwarding in Spur. Also the check for the
method object matching is superfluous.
Include page in printing of frames on in use stack page list.
Real close. ShootoutTests runAllToTranscript runs twp cases before
crapping out in GC.
=============== Diff against VMMaker.oscog-eem.503 ===============
Item was changed:
----- Method: CoInterpreter>>checkStackIntegrity (in category 'object memory support') -----
checkStackIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccesibleObjects has set a bit at each
object's header. Scan all objects accessible from the stack
checking that every pointer points to a header. Answer if no
dangling pointers were detected."
| ok |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #cogMethod type: #'CogMethod *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP frameRcvrOffset callerFP oop |
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage = stackPage
ifTrue:
[theSP := stackPointer.
theFP := framePointer]
ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP].
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' andFrame: theFP at: theSP.
ok := false].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isImmediate: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
+ (objectMemory isContext: oop) ifFalse:
- (oop = objectMemory nilObject or: [objectMemory isContext: oop]) ifFalse:
[self printFrameThing: 'frame ctxt should be context' andFrame: theFP at: theFP + FoxThisContext.
+ ok := false].
+ ((objectMemory isContext: oop) and: [self isMarriedOrWidowedContext: oop]) ifFalse:
+ [self printFrameThing: 'frame ctxt should be married' andFrame: theFP at: theFP + FoxThisContext.
+ ok := false].
+ ((objectMemory isContext: oop) and: [(self frameOfMarriedContext: oop) = theFP]) ifFalse:
+ [self printFrameThing: 'frame ctxt should be married to this frame ' andFrame: theFP at: theFP + FoxThisContext.
ok := false]].
(self isMachineCodeFrame: theFP)
ifTrue:
[| cogMethod |
cogMethod := self mframeHomeMethod: theFP.
(self heapMapAtWord: (self pointerForOop: cogMethod)) = 0 ifTrue:
[self printFrameThing: 'object leak in mframe mthd' andFrame: theFP at: theFP + FoxMethod.
ok := false]]
ifFalse:
[oop := self iframeMethod: theFP.
((objectMemory isImmediate: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in iframe mthd' andFrame: theFP at: theFP + FoxMethod.
ok := false]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' andFrame: theFP at: theSP.
ok := false].
theSP := theSP + BytesPerWord]]].
^ok!
Item was changed:
----- Method: CoInterpreter>>mapStackPages (in category 'object memory support') -----
mapStackPages
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #frameRcvrOffset type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #'char *'>
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP frameRcvrOffset callerFP theIPPtr theIP oop |
thePage := stackPages stackPageAt: i.
thePage isFree ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage
ifTrue: [theIPPtr := ((self isMachineCodeFrame: theFP)
or: [(self iframeSavedIP: theFP) = 0])
ifTrue: [0]
ifFalse: [theFP + FoxIFSavedIP]]
ifFalse:
[theIPPtr := theSP.
theSP := theSP + BytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (thePage addressIsInPage: theSP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
frameRcvrOffset := self frameReceiverOffset: theFP.
[theSP <= frameRcvrOffset] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
theSP := theSP + BytesPerWord].
+ (self frameHasContext: theFP) ifTrue:
+ [(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
+ [stackPages
+ longAt: theFP + FoxThisContext
+ put: (objectMemory remapObj: (self frameContext: theFP))].
+ self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
+ and: [(self frameOfMarriedContext: (self frameContext: theFP)) = theFP])].
- ((self frameHasContext: theFP)
- and: [objectMemory shouldRemapObj: (self frameContext: theFP)]) ifTrue:
- [stackPages
- longAt: theFP + FoxThisContext
- put: (objectMemory remapObj: (self frameContext: theFP))].
(self isMachineCodeFrame: theFP) ifFalse:
[(objectMemory shouldRemapObj: (self iframeMethod: theFP)) ifTrue:
[theIPPtr ~= 0 ifTrue:
[theIP := stackPages longAt: theIPPtr.
theIP = cogit ceReturnToInterpreterPC
ifTrue:
[self assert: (self iframeSavedIP: theFP) > (self iframeMethod: theFP).
theIPPtr := theFP + FoxIFSavedIP.
theIP := stackPages longAt: theIPPtr]
ifFalse:
[self assert: theIP > (self iframeMethod: theFP)].
theIP := theIP - (self iframeMethod: theFP)].
stackPages
longAt: theFP + FoxMethod
put: (objectMemory remapObj: (self iframeMethod: theFP)).
theIPPtr ~= 0 ifTrue:
[stackPages longAt: theIPPtr put: theIP + (self iframeMethod: theFP)]]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := (theIPPtr := theFP + FoxCallerSavedIP) + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
theSP := theSP + BytesPerWord]]]!
Item was removed:
- ----- Method: Spur32BitMMLECoSimulator>>runLeakCheckerForFullGC: (in category 'debug support') -----
- runLeakCheckerForFullGC: fullGCFlag
- (fullGCFlag
- ifTrue: [self leakCheckFullGC]
- ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
- [coInterpreter transcript nextPutAll: 'leak-checking...'; flush]!
Item was added:
+ ----- Method: Spur32BitMMLECoSimulator>>runLeakCheckerForFullGC:excludeUnmarkedNewSpaceObjs: (in category 'debug support') -----
+ runLeakCheckerForFullGC: fullGCFlag excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
+ (fullGCFlag
+ ifTrue: [self leakCheckFullGC]
+ ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
+ ^super runLeakCheckerForFullGC: fullGCFlag excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs!
Item was removed:
- ----- Method: Spur32BitMMLESimulator>>runLeakCheckerForFullGC: (in category 'debug support') -----
- runLeakCheckerForFullGC: fullGCFlag
- (fullGCFlag
- ifTrue: [self leakCheckFullGC]
- ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
- [coInterpreter transcript nextPutAll: 'leak-checking...'; flush]!
Item was added:
+ ----- Method: Spur32BitMMLESimulator>>runLeakCheckerForFullGC:excludeUnmarkedNewSpaceObjs: (in category 'debug support') -----
+ runLeakCheckerForFullGC: fullGCFlag excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
+ (fullGCFlag
+ ifTrue: [self leakCheckFullGC]
+ ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
+ [coInterpreter transcript nextPutAll: 'leak-checking...'; flush].
+ ^super runLeakCheckerForFullGC: fullGCFlag excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs!
Item was changed:
----- Method: Spur32BitMMLESimulator>>scavengingGCTenuringIf: (in category 'generation scavenging') -----
scavengingGCTenuringIf: tenuringCriterion
"Run the scavenger."
"self halt: (statScavenges + 1) printString, ((statScavenges between: 9 and: 19)
ifTrue: ['th']
ifFalse: [#('st' 'nd' 'rd') at: (statScavenges + 1) \\ 10 ifAbsent: 'th']), ' scavenge'."
+
+ "statFullGCs > 0 ifTrue:
+ [self halt]."
^super scavengingGCTenuringIf: tenuringCriterion!
Item was changed:
----- Method: Spur32BitMemoryManager>>initFreeChunkWithBytes:at: (in category 'free space') -----
initFreeChunkWithBytes: numBytes at: address
<var: #numBytes type: #usqLong>
| numSlots |
"must have room for a header (single or double) plus the next free pointer"
self assert: (numBytes \\ self allocationUnit = 0
and: [numBytes >= (self baseHeaderSize + self wordSize)]).
self flag: #endianness.
"double header"
+ numBytes >= ((self numSlotsMask << self shiftForWord) + self baseHeaderSize) ifTrue:
- numBytes >= ((self numSlotsMask << self shiftForWord) + self baseHeaderSize + self baseHeaderSize) ifTrue:
[numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord.
- self assert: numSlots >= self numSlotsMask.
self longAt: address put: numSlots;
longAt: address + 4 put: self numSlotsMask << self numSlotsHalfShift;
longAt: address + 8 put: 0; "0's classIndex; 0 = classIndex of free chunks"
longAt: address + 12 put: self numSlotsMask << self numSlotsHalfShift.
^address + 8].
"single header"
numSlots := numBytes - self baseHeaderSize >> self shiftForWord.
self assert: numSlots < self numSlotsMask.
self longAt: address put: 0; "0's classIndex; 0 = classIndex of free chunks"
longAt: address + 4 put: numSlots << self numSlotsHalfShift.
^address!
Item was changed:
----- Method: Spur64BitMemoryManager>>initFreeChunkWithBytes:at: (in category 'free space') -----
initFreeChunkWithBytes: numBytes at: address
<var: #numBytes type: #usqLong>
| numSlots |
"must have room for a header (single or double) plus the next free pointer"
self assert: (numBytes \\ self allocationUnit = 0
and: [numBytes >= (self baseHeaderSize + self wordSize)]).
"double header"
+ numBytes >= ((self numSlotsMask << self shiftForWord) + self baseHeaderSize) ifTrue:
- numBytes >= ((self numSlotsMask << self shiftForWord) + self baseHeaderSize + self baseHeaderSize) ifTrue:
[numSlots := numBytes - self baseHeaderSize - self baseHeaderSize >> self shiftForWord.
- self assert: numSlots >= self numSlotsMask.
self longAt: address put: self numSlotsMask << self numSlotsFullShift + numSlots;
longAt: address + 8 put: self numSlotsMask << self numSlotsFullShift. "0's classIndex; 0 = classIndex of free chunks"
^address + 8].
"single header"
numSlots := numBytes - self baseHeaderSize >> self shiftForWord.
self assert: numSlots < self numSlotsMask.
self longAt: address put: numSlots << self numSlotsFullShift. "0's classIndex; 0 = classIndex of free chunks"
^address!
Item was changed:
----- Method: SpurCircularBuffer>>resetAsEmpty (in category 'accessing') -----
resetAsEmpty
+ first := start.
last := start - manager wordSize!
Item was changed:
----- Method: SpurGenerationScavenger class>>initialize (in category 'class initialization') -----
initialize
"SpurGenerationScavenger initialize"
+ RememberedSetLimit := 64 * 1024. "temporary; must move to heap"
- RememberedSetLimit := 16384.
RememberedSetRedZone := RememberedSetLimit - (RememberedSetLimit // 2).
TenureByAge := 1.
TenureByClass := 2.
DontTenureButDoUnmark := 3!
Item was changed:
----- Method: SpurGenerationScavenger>>copyToOldSpace: (in category 'scavenger') -----
copyToOldSpace: survivor
"Copy survivor to oldSpace. Answer the new oop of the object."
<inline: true>
+ | nTenures numSlots newOop |
+ nTenures := statTenures.
- | numSlots newOop |
- statTenures := statTenures + 1.
self flag: 'why not just pass header??'.
numSlots := manager numSlotsOf: survivor.
newOop := manager
allocateSlotsInOldSpace: numSlots
format: (manager formatOf: survivor)
classIndex: (manager classIndexOf: survivor).
newOop ifNil:
+ [manager growOldSpaceByAtLeast: 0. "grow by growHeadroom"
+ newOop := manager
+ allocateSlotsInOldSpace: numSlots
+ format: (manager formatOf: survivor)
+ classIndex: (manager classIndexOf: survivor).
+ newOop ifNil:
+ [self error: 'out of memory']].
- [self error: 'out of memory'].
manager
mem: (newOop + manager baseHeaderSize) asVoidPointer
cp: (survivor + manager baseHeaderSize) asVoidPointer
y: numSlots * manager wordSize.
self remember: newOop.
manager setIsRememberedOf: newOop to: true.
+ statTenures := nTenures + 1.
^newOop!
Item was changed:
----- Method: SpurMemoryManager>>addFreeSubTree: (in category 'free space') -----
addFreeSubTree: freeTree
"Add a freeChunk sub tree back into the large free chunk tree.
+ This is for allocateOldSpaceChunkOf[Exactly]Bytes:[suchThat:]."
+ | bytesInArg treeNode bytesInNode subNode |
+ "N.B. *can't* use numSlotsOfAny: because of rounding up of odd slots
+ and/or step in size at 1032 bytes in 32-bits or 2048 bytes in 64-bits."
+ bytesInArg := self bytesInObject: freeTree.
+ self assert: bytesInArg / (self allocationUnit / self wordSize) >= self numFreeLists.
- This is for allocateOldSpaceChunkOf[Exactly]Bytes:."
- | slotsInArg treeNode slotsInNode subNode |
- slotsInArg := self numSlotsOfAny: freeTree.
- self assert: slotsInArg / (self allocationUnit / self wordSize) >= self numFreeLists.
treeNode := freeLists at: 0.
self assert: treeNode ~= 0.
+ [bytesInNode := self bytesInObject: treeNode.
+ self assert: bytesInArg ~= bytesInNode.
+ bytesInNode > bytesInArg
- [slotsInNode := self numSlotsOfAny: treeNode.
- self assert: slotsInArg ~= slotsInNode.
- slotsInNode > slotsInArg
ifTrue:
[subNode := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: treeNode.
subNode = 0 ifTrue:
[self storePointer: self freeChunkSmallerIndex ofFreeChunk: treeNode withValue: freeTree.
self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode.
^self]]
ifFalse:
[subNode := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: treeNode.
subNode = 0 ifTrue:
[self storePointer: self freeChunkLargerIndex ofFreeChunk: treeNode withValue: freeTree.
self storePointer: self freeChunkParentIndex ofFreeChunk: freeTree withValue: treeNode.
^self]].
treeNode := subNode] repeat!
Item was removed:
- ----- Method: SpurMemoryManager>>checkHeapIntegrity (in category 'debug support') -----
- checkHeapIntegrity
- "Perform an integrity/leak check using the heapMap. Assume
- clearLeakMapAndMapAccessibleObjects has set a bit at each
- object's header. Scan all objects in the heap checking that every
- pointer points to a header. Scan the rootTable, remapBuffer and
- extraRootTable checking that every entry is a pointer to a header.
- Check that the number of roots is correct and that all rootTable
- entries have their rootBit set. Answer if all checks pass."
- | prevObj prevPrevObj ok numRememberedRootsInHeap |
- <inline: false>
- ok := true.
- numRememberedRootsInHeap := 0.
- self allHeapEntitiesDo:
- [:obj| | containsYoung fieldOop classIndex classOop |
- (self isFreeObject: obj) ifFalse:
- [containsYoung := false.
- (self isRemembered: obj) ifTrue:
- [numRememberedRootsInHeap := numRememberedRootsInHeap + 1.
- (scavenger isInRememberedSet: obj) ifFalse:
- [coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr.
- self eek.
- ok := false]].
- (self isForwarded: obj)
- ifTrue:
- [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
- (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
- [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
- self eek.
- ok := false].
- (self isYoung: fieldOop) ifTrue:
- [containsYoung := true]]
- ifFalse:
- [classOop := self classAtIndex: (classIndex := self classIndexOf: obj).
- ((classOop isNil or: [classOop = nilObj])
- and: [(self isHiddenObj: obj) not]) ifTrue:
- [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
- self eek.
- ok := false].
- self baseHeaderSize to: (self lastPointerOf: obj) by: BytesPerOop do:
- [:ptr|
- fieldOop := self longAt: obj + ptr.
- (self isNonImmediate: fieldOop) ifTrue:
- [| fi |
- fi := ptr - self baseHeaderSize / self wordSize.
- (fieldOop bitAnd: self wordSize - 1) ~= 0
- ifTrue:
- [coInterpreter print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
- self eek.
- ok := false]
- ifFalse:
- [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
- [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
- self eek.
- ok := false].
- "don't be misled by CogMethods; they appear to be young, but they're not"
- ((self isYoung: fieldOop) and: [fieldOop >= startOfMemory]) ifTrue:
- [containsYoung := true]]]]].
- (containsYoung and: [(self isYoung: obj) not]) ifTrue:
- [(self isRemembered: obj) ifFalse:
- [coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr.
- self eek.
- ok := false]]].
- prevPrevObj := prevObj.
- prevObj := obj].
- numRememberedRootsInHeap ~= scavenger rememberedSetSize ifTrue:
- [coInterpreter
- print: 'root count mismatch. #heap roots ';
- printNum: numRememberedRootsInHeap;
- print: '; #roots ';
- printNum: scavenger rememberedSetSize;
- cr.
- self eek.
- "But the system copes with overflow..."
- self flag: 'no support for remembered set overflow yet'.
- "ok := rootTableOverflowed and: [needGCFlag]"].
- scavenger rememberedSetWithIndexDo:
- [:obj :i|
- (obj bitAnd: self wordSize - 1) ~= 0
- ifTrue:
- [coInterpreter print: 'misaligned oop in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
- self eek.
- ok := false]
- ifFalse:
- [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
- ifTrue:
- [coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
- self eek.
- ok := false]
- ifFalse:
- [(self isYoung: obj) ifTrue:
- [coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
- self eek.
- ok := false]]]].
- 1 to: remapBufferCount do:
- [:ri| | obj |
- obj := remapBuffer at: ri.
- (obj bitAnd: self wordSize - 1) ~= 0
- ifTrue:
- [coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
- self eek.
- ok := false]
- ifFalse:
- [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
- [coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
- self eek.
- ok := false]]].
- 1 to: extraRootCount do:
- [:ri| | obj |
- obj := (extraRoots at: ri) at: 0.
- (obj bitAnd: self wordSize - 1) ~= 0
- ifTrue:
- [coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
- self eek.
- ok := false]
- ifFalse:
- [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
- [coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
- self eek.
- ok := false]]].
- ^ok!
Item was added:
+ ----- Method: SpurMemoryManager>>checkHeapIntegrity: (in category 'debug support') -----
+ checkHeapIntegrity: excludeUnmarkedNewSpaceObjs
+ "Perform an integrity/leak check using the heapMap. Assume
+ clearLeakMapAndMapAccessibleObjects has set a bit at each
+ object's header. Scan all objects in the heap checking that every
+ pointer points to a header. Scan the rootTable, remapBuffer and
+ extraRootTable checking that every entry is a pointer to a header.
+ Check that the number of roots is correct and that all rootTable
+ entries have their rootBit set. Answer if all checks pass."
+ | ok numRememberedRootsInHeap |
+ <inline: false>
+ ok := true.
+ numRememberedRootsInHeap := 0.
+ self allHeapEntitiesDo:
+ [:obj| | containsYoung fieldOop classIndex classOop |
+ ((self isFreeObject: obj)
+ or: [(self isYoung: obj) and: [(self isMarked: obj) not and: [excludeUnmarkedNewSpaceObjs]]]) ifFalse:
+ [containsYoung := false.
+ (self isRemembered: obj) ifTrue:
+ [numRememberedRootsInHeap := numRememberedRootsInHeap + 1.
+ (scavenger isInRememberedSet: obj) ifFalse:
+ [coInterpreter print: 'remembered object '; printHex: obj; print: ' is not in remembered table'; cr.
+ self eek.
+ ok := false]].
+ (self isForwarded: obj)
+ ifTrue:
+ [fieldOop := self fetchPointer: 0 ofMaybeForwardedObject: obj.
+ (heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
+ [coInterpreter print: 'object leak in forwarder '; printHex: obj; print: ' to unmapped '; printHex: fieldOop; cr.
+ self eek.
+ ok := false].
+ (self isYoung: fieldOop) ifTrue:
+ [containsYoung := true]]
+ ifFalse:
+ [classOop := self classAtIndex: (classIndex := self classIndexOf: obj).
+ ((classOop isNil or: [classOop = nilObj])
+ and: [(self isHiddenObj: obj) not]) ifTrue:
+ [coInterpreter print: 'object leak in '; printHex: obj; print: ' invalid class index '; printHex: classIndex; print: ' -> '; print: (classOop ifNil: ['nil'] ifNotNil: ['nilObj']); cr.
+ self eek.
+ ok := false].
+ self baseHeaderSize to: (self lastPointerOf: obj) by: BytesPerOop do:
+ [:ptr|
+ fieldOop := self longAt: obj + ptr.
+ (self isNonImmediate: fieldOop) ifTrue:
+ [| fi |
+ fi := ptr - self baseHeaderSize / self wordSize.
+ (fieldOop bitAnd: self wordSize - 1) ~= 0
+ ifTrue:
+ [coInterpreter print: 'misaligned oop in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ self eek.
+ ok := false]
+ ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0 ifTrue:
+ [coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; cr.
+ self eek.
+ ok := false].
+ "don't be misled by CogMethods; they appear to be young, but they're not"
+ ((self isYoung: fieldOop) and: [fieldOop >= startOfMemory]) ifTrue:
+ [containsYoung := true]]]]].
+ (containsYoung and: [(self isYoung: obj) not]) ifTrue:
+ [(self isRemembered: obj) ifFalse:
+ [coInterpreter print: 'unremembered object '; printHex: obj; print: ' contains young oop(s)'; cr.
+ self eek.
+ ok := false]]]].
+ numRememberedRootsInHeap ~= scavenger rememberedSetSize ifTrue:
+ [coInterpreter
+ print: 'root count mismatch. #heap roots ';
+ printNum: numRememberedRootsInHeap;
+ print: '; #roots ';
+ printNum: scavenger rememberedSetSize;
+ cr.
+ self eek.
+ "But the system copes with overflow..."
+ self flag: 'no support for remembered set overflow yet'.
+ "ok := rootTableOverflowed and: [needGCFlag]"].
+ scavenger rememberedSetWithIndexDo:
+ [:obj :i|
+ (obj bitAnd: self wordSize - 1) ~= 0
+ ifTrue:
+ [coInterpreter print: 'misaligned oop in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
+ self eek.
+ ok := false]
+ ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0
+ ifTrue:
+ [coInterpreter print: 'object leak in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
+ self eek.
+ ok := false]
+ ifFalse:
+ [(self isYoung: obj) ifTrue:
+ [coInterpreter print: 'non-root in remembered set @ '; printNum: i; print: ' = '; printHex: obj; cr.
+ self eek.
+ ok := false]]]].
+ 1 to: remapBufferCount do:
+ [:ri| | obj |
+ obj := remapBuffer at: ri.
+ (obj bitAnd: self wordSize - 1) ~= 0
+ ifTrue:
+ [coInterpreter print: 'misaligned remapRoot @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
+ ok := false]
+ ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
+ [coInterpreter print: 'object leak in remapRoots @ '; printNum: ri; print: ' = '; printHex: obj; cr.
+ self eek.
+ ok := false]]].
+ 1 to: extraRootCount do:
+ [:ri| | obj |
+ obj := (extraRoots at: ri) at: 0.
+ (obj bitAnd: self wordSize - 1) ~= 0
+ ifTrue:
+ [coInterpreter print: 'misaligned extraRoot @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ self eek.
+ ok := false]
+ ifFalse:
+ [(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
+ [coInterpreter print: 'object leak in extraRoots @ '; printNum: ri; print: ' => '; printHex: obj; cr.
+ self eek.
+ ok := false]]].
+ ^ok!
Item was changed:
----- Method: SpurMemoryManager>>checkOkayOop: (in category 'debug support') -----
checkOkayOop: oop
"Verify that the given oop is legitimate. Check address, header, and size but not class.
Answer true if OK. Otherwise print reason and answer false."
<api>
<var: #oop type: #usqInt>
| classIndex fmt unusedBits unusedBitsInYoungObjects |
<var: #unusedBits type: #usqLong>
"address and size checks"
(self isImmediate: oop) ifTrue: [^true].
(self addressCouldBeObjWhileScavenging: oop) ifFalse:
[self print: 'oop '; printHex: oop; print: ' is not a valid address'. ^false].
(self addressAfter: oop) <= freeOldSpaceStart ifFalse:
[self print: 'oop '; printHex: oop; print: ' size would make it extend beyond the end of memory'. ^false].
"header type checks"
(classIndex := self classIndexOf: oop) >= self firstClassIndexPun ifFalse:
[self print: 'oop '; printHex: oop; print: ' is a free chunk, or bridge, not an object'. ^false].
((self rawNumSlotsOf: oop) = self numSlotsMask
+ and: [(self rawNumSlotsOf: oop - self baseHeaderSize) ~= self numSlotsMask]) ifTrue:
- and: [(self rawNumSlotsOf: oop) - self baseHeaderSize ~= self numSlotsMask]) ifTrue:
[self print: 'oop '; printHex: oop; print: ' header has overflow header word, but overflow word does not have a saturated numSlots field'. ^false].
"format check"
fmt := self formatOf: oop.
(fmt = 6) | (fmt = 8) ifTrue:
[self print: 'oop '; printHex: oop; print: ' has an unknown format type'. ^false].
(fmt = self forwardedFormat) ~= (classIndex = self isForwardedObjectClassIndexPun) ifTrue:
+ [self print: 'oop '; printHex: oop; print: ' has mis-matched format/classIndex fields; only one of them is the isForwarded value'. ^false].
- [self print: 'oop '; printHex: oop; print: ' has mismached format/classIndex fields; only one of them is the isForwarded value'. ^false].
"specific header bit checks"
unusedBits := (1 << self classIndexFieldWidth)
| (1 << (self identityHashFieldWidth + 32)).
((self longLongAt: oop) bitAnd: unusedBits) ~= 0 ifTrue:
[self print: 'oop '; printHex: oop; print: ' has some unused header bits set; should be zero'. ^false].
unusedBitsInYoungObjects := self newSpaceRefCountMask.
((self longAt: oop) bitAnd: unusedBitsInYoungObjects) ~= 0 ifTrue:
[self print: 'oop '; printHex: oop; print: ' has some header bits unused in young objects set; should be zero'. ^false].
^true!
Item was changed:
----- Method: SpurMemoryManager>>eliminateAndFreeForwarders (in category 'gc - global') -----
eliminateAndFreeForwarders
"As the final phase of global garbage collect, sweep
the heap to follow forwarders, then free forwarders"
| lowestForwarded firstForwarded lastForwarded |
<inline: false>
self assert: (self isForwarded: nilObj) not.
self assert: (self isForwarded: falseObj) not.
self assert: (self isForwarded: trueObj) not.
+ self assert: (self isForwarded: self freeListsObj) not.
self assert: (self isForwarded: hiddenRootsObj) not.
+ self assert: (self isForwarded: classTableFirstPage) not.
(self isForwarded: specialObjectsOop) ifTrue:
[specialObjectsOop := self followForwarded: specialObjectsOop].
+ "N.B. we don't have to explcitly do mapInterpreterOops
+ since the scavenge below will do it."
self followForwardedObjStacks.
scavenger followRememberedForwardersAndForgetFreeObjects.
self doScavenge: DontTenureButDoUnmark.
+ self checkFreeSpace.
lowestForwarded := 0.
"sweep, following forwarders in all live objects, and finding the first forwarder."
self allOldSpaceObjectsDo:
[:o|
(self isForwarded: o)
ifTrue:
[lowestForwarded = 0 ifTrue:
[lowestForwarded := o]]
ifFalse:
[0 to: (self numPointerSlotsOf: o) - 1 do:
[:i| | f |
f := self fetchPointer: i ofObject: o.
(self isOopForwarded: f) ifTrue:
[f := self followForwarded: f.
self assert: ((self isImmediate: f) or: [self isYoung: f]) not.
self storePointerUnchecked: i ofObject: o withValue: f]]]].
+ self checkFreeSpace.
firstForwarded := lastForwarded := 0.
+ "sweep from lowest forwarder, coalescing runs of forwarders. perhaps this should
+ coalewsce free space and forwarders. the previous loop could reprise the discarding
+ of free space in freeUnmarkedObjectsAndSortAndCoalesceFreeSpace."
+ self allOldSpaceEntitiesFrom: lowestForwarded do:
- "sweep from lowest forwarder, coalescing runs of forwarders."
- self allOldSpaceObjectsFrom: lowestForwarded do:
[:o|
(self isForwarded: o)
ifTrue:
[firstForwarded = 0 ifTrue:
[firstForwarded := o].
lastForwarded := o]
ifFalse:
[firstForwarded ~= 0 ifTrue:
[| start bytes |
start := self startOfObject: firstForwarded.
bytes := (self addressAfter: lastForwarded) - start.
self addFreeChunkWithBytes: bytes at: start].
firstForwarded := 0]].
firstForwarded ~= 0 ifTrue:
[| start bytes |
start := self startOfObject: firstForwarded.
bytes := (self addressAfter: lastForwarded) - start.
+ self addFreeChunkWithBytes: bytes at: start].
+ self checkFreeSpace!
- self addFreeChunkWithBytes: bytes at: start].!
Item was changed:
----- Method: SpurMemoryManager>>fillHighestObjectsWithMovableObjectsFrom:upTo: (in category 'compaction') -----
fillHighestObjectsWithMovableObjectsFrom: startObj upTo: limitObj
"Refill highestObjects with movable objects up to, but not including limitObj.
c.f. the loop in freeUnmarkedObjectsNilUnmarkedWeaklingSlotsAndSortAndCoalesceFreeSpace."
| lastHighest highestObjectsWraps |
+ highestObjects resetAsEmpty.
lastHighest := highestObjects last.
highestObjectsWraps := 0.
self allOldSpaceObjectsFrom: startObj do:
[:o|
o >= limitObj ifTrue:
[highestObjects last: lastHighest.
^self].
((self isForwarded: o) or: [self isPinned: o]) ifFalse:
[false "conceptually...: "
ifTrue: [highestObjects addLast: o]
ifFalse: "but we inline so we can use the local lastHighest"
[(lastHighest := lastHighest + self wordSize) >= highestObjects limit ifTrue:
[highestObjectsWraps := highestObjectsWraps + 1].
self longAt: lastHighest put: o]]].
highestObjects last: lastHighest!
Item was changed:
----- Method: SpurMemoryManager>>globalGarbageCollect (in category 'gc - global') -----
globalGarbageCollect
self runLeakCheckerForFullGC: true.
self assert: self validObjStacks.
self markObjects.
self nilUnmarkedWeaklingSlots.
self freeUnmarkedObjectsAndSortAndCoalesceFreeSpace.
+ self runLeakCheckerForFullGC: true excludeUnmarkedNewSpaceObjs: true.
- self runLeakCheckerForFullGC: true.
self compact.
self eliminateAndFreeForwarders.
self assert: self validObjStacks.
self assert: self allObjectsUnmarked.
self runLeakCheckerForFullGC: true!
Item was changed:
----- Method: SpurMemoryManager>>moveMisfitsToTopOfHighestObjects: (in category 'compaction') -----
moveMisfitsToTopOfHighestObjects: misfits
"After a cycle of exact-fit compaction highestObjects may contain some
number of mobile objects that fail to fit, and more objects may exist to
move. Move existing misfits to top of highestObjects and temporarily
shrink highestObjects to refill it without overwriting misfits. Answer the
old limit. moveMisfitsInHighestObjectsBack: will undo the change."
| oldLimit bytesToMove |
oldLimit := highestObjects limit.
misfits = (highestObjects last + self wordSize) ifTrue:
+ [^oldLimit].
- [highestObjects resetAsEmpty.
- ^oldLimit].
misfits <= highestObjects last ifTrue:
[bytesToMove := highestObjects last + self wordSize - misfits.
self mem: (highestObjects limit - bytesToMove) asVoidPointer
mo: misfits asVoidPointer
ve: bytesToMove.
highestObjects limit: misfits - self wordSize.
^oldLimit].
"misfits wrapped; move in two stages to preserve ordering"
bytesToMove := highestObjects last - highestObjects start.
self mem: (misfits - bytesToMove) asVoidPointer
mo: misfits asVoidPointer
ve: oldLimit - misfits.
highestObjects limit: misfits - bytesToMove.
self mem: (oldLimit - bytesToMove) asVoidPointer
mo: highestObjects start asVoidPointer
ve: bytesToMove.
^oldLimit!
Item was changed:
----- Method: SpurMemoryManager>>okayOop: (in category 'debug support') -----
okayOop: signedOop
"Verify that the given oop is legitimate. Check address, header, and size but not class."
| oop classIndex fmt unusedBits unusedBitsInYoungObjects |
<var: #oop type: #usqInt>
<var: #unusedBits type: #usqLong>
oop := self cCoerce: signedOop to: #usqInt.
"address and size checks"
(self isImmediate: oop) ifTrue: [^true].
(self addressCouldBeObjWhileScavenging: oop) ifFalse:
[self error: 'oop is not a valid address'. ^false].
(self addressAfter: oop) <= freeOldSpaceStart ifFalse:
[self error: 'oop size would make it extend beyond the end of memory'. ^false].
"header type checks"
(classIndex := self classIndexOf: oop) >= self firstClassIndexPun ifFalse:
[self error: 'oop is a free chunk, or bridge, not an object'. ^false].
((self rawNumSlotsOf: oop) = self numSlotsMask
+ and: [(self rawNumSlotsOf: oop - self baseHeaderSize) ~= self numSlotsMask]) ifTrue:
- and: [(self rawNumSlotsOf: oop) - self baseHeaderSize ~= self numSlotsMask]) ifTrue:
[self error: 'oop header has overflow header word, but overflow word does not have a saturated numSlots field'. ^false].
"format check"
fmt := self formatOf: oop.
(fmt = 6) | (fmt = 8) ifTrue:
[self error: 'oop has an unknown format type'. ^false].
(fmt = self forwardedFormat) ~= (classIndex = self isForwardedObjectClassIndexPun) ifTrue:
+ [self error: 'oop has mis-matched format/classIndex fields; only one of them is the isForwarded value'. ^false].
- [self error: 'oop has mismached format/classIndex fields; only one of them is the isForwarded value'. ^false].
"specific header bit checks"
unusedBits := (1 << self classIndexFieldWidth)
| (1 << (self identityHashFieldWidth + 32)).
((self longLongAt: oop) bitAnd: unusedBits) ~= 0 ifTrue:
[self error: 'some unused header bits are set; should be zero'. ^false].
unusedBitsInYoungObjects := (1 << self greyBitShift)
| (1 << self pinnedBitShift)
| (1 << self rememberedBitShift).
((self longAt: oop) bitAnd: unusedBitsInYoungObjects) ~= 0 ifTrue:
[self error: 'some header bits unused in young objects are set; should be zero'. ^false].
^true
!
Item was changed:
----- Method: SpurMemoryManager>>remapObj: (in category 'gc - scavenging') -----
remapObj: objOop
"Scavenge or simply follow objOop. Answer the new location of objOop. The
send should have been guarded by a send of shouldRemapOop: or shouldScavengeObj:.
The method is called remapObj: for compatibility with ObjectMemory."
<inline: false>
| resolvedObj |
self assert: (self shouldRemapOop: objOop).
(self isForwarded: objOop)
ifTrue:
[resolvedObj := self followForwarded: objOop.
- (self isYoung: resolvedObj) ifFalse: "a becommed object whose target is in old space"
- [^resolvedObj].
(self isInFutureSpace: resolvedObj) ifTrue: "already scavenged"
[^resolvedObj]]
ifFalse:
[resolvedObj := objOop].
+ (self isYoung: resolvedObj) ifFalse: "a becommed or compacted object whose target is in old space"
+ [^resolvedObj].
^scavenger copyAndForward: resolvedObj!
Item was changed:
----- Method: SpurMemoryManager>>runLeakCheckerForFullGC: (in category 'debug support') -----
runLeakCheckerForFullGC: fullGCFlag
+ ^self runLeakCheckerForFullGC: fullGCFlag excludeUnmarkedNewSpaceObjs: false!
- <inline: false>
- (fullGCFlag
- ifTrue: [self leakCheckFullGC]
- ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
- [fullGCFlag
- ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7]
- ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15].
- self clearLeakMapAndMapAccessibleObjects.
- self assert: self checkHeapIntegrity.
- self assert: coInterpreter checkInterpreterIntegrity.
- self assert: coInterpreter checkStackIntegrity.
- self assert: (coInterpreter checkCodeIntegrity: fullGCFlag)]!
Item was added:
+ ----- Method: SpurMemoryManager>>runLeakCheckerForFullGC:excludeUnmarkedNewSpaceObjs: (in category 'debug support') -----
+ runLeakCheckerForFullGC: fullGCFlag excludeUnmarkedNewSpaceObjs: excludeUnmarkedNewSpaceObjs
+ <inline: false>
+ (fullGCFlag
+ ifTrue: [self leakCheckFullGC]
+ ifFalse: [self leakCheckNewSpaceGC]) ifTrue:
+ [fullGCFlag
+ ifTrue: [coInterpreter reverseDisplayFrom: 0 to: 7]
+ ifFalse: [coInterpreter reverseDisplayFrom: 8 to: 15].
+ self clearLeakMapAndMapAccessibleObjects.
+ self assert: (self checkHeapIntegrity: excludeUnmarkedNewSpaceObjs).
+ self assert: coInterpreter checkInterpreterIntegrity.
+ self assert: coInterpreter checkStackIntegrity.
+ self assert: (coInterpreter checkCodeIntegrity: fullGCFlag)]!
Item was changed:
----- Method: SpurMemoryManager>>sizeOfFree: (in category 'free space') -----
sizeOfFree: objOop
+ "For compatibility with ObjectMemory, answer the size of a free chunk in bytes.
+ Do *not* use internally."
- "For compatibility with ObjectMemory, answer the size of a free chunk in bytes,
- ignoring the overflow header. Do *not* use internally."
self assert: (self isFreeObject: objOop).
+ ^self bytesInObject: objOop!
- ^self baseHeaderSize + (self wordSize * (self numSlotsOfAny: objOop))!
Item was changed:
----- Method: SpurMemoryManager>>startOfObject: (in category 'object enumeration') -----
startOfObject: objOop
+ "Answer the start of objOop, which is either the address of the overflow
+ size word, or objOop itself, depending on the size of the object. This may
+ be applied to any kind of object, normal, forwarders or free chunks."
+ ^(self hasOverflowHeader: objOop)
- "Answer the start of objOop, which is either the address of the overflow size word,
- or objOop itself, depending on the size of the object. This may be applied to
- any kind of object, normal, forwarders or free chunks."
- ^(self numSlotsOfAny: objOop) >= self numSlotsMask
ifTrue: [objOop - self baseHeaderSize]
ifFalse: [objOop]!
Item was changed:
----- Method: SpurMemoryManager>>storePointer:ofFreeChunk:withValue: (in category 'heap management') -----
storePointer: fieldIndex ofFreeChunk: objOop withValue: valuePointer
self assert: (self isFreeObject: objOop).
+ self assert: (valuePointer = 0 or: [self isFreeObject: valuePointer]).
- self assert: (valuePointer = 0 or: [self isFreeObject: objOop]).
^self
longAt: objOop + self baseHeaderSize + (fieldIndex << self shiftForWord)
put: valuePointer!
Item was added:
+ ----- Method: SpurMemoryManager>>storePointerNoAssert:ofFreeChunk:withValue: (in category 'heap management') -----
+ storePointerNoAssert: fieldIndex ofFreeChunk: objOop withValue: valuePointer
+
+ ^self
+ longAt: objOop + self baseHeaderSize + (fieldIndex << self shiftForWord)
+ put: valuePointer!
Item was changed:
----- Method: SpurMemoryManager>>swizzleFieldsOfFreeChunk: (in category 'snapshot') -----
swizzleFieldsOfFreeChunk: chunk
<inline: true>
0 to: ((self bytesInObject: chunk) / self allocationUnit > self numFreeLists
ifTrue: [self freeChunkLargerIndex]
ifFalse: [self freeChunkNextIndex])
do: [:index| | field |
field := self fetchPointer: index ofFreeChunk: chunk.
field ~= 0 ifTrue:
+ [self storePointerNoAssert: index
- [self storePointer: index
ofFreeChunk: chunk
withValue: (segmentManager swizzleObj: field)]]!
Item was changed:
----- Method: SpurMemoryManager>>unlinkSolitaryFreeTreeNode: (in category 'free space') -----
unlinkSolitaryFreeTreeNode: freeTreeNode
"Unlink a freeTreeNode. Assumes the node has no list (null next link)."
| parent smaller larger |
self assert: (self fetchPointer: self freeChunkNextIndex ofObject: freeTreeNode) = 0.
"case 1. interior node has one child, P = parent, N = node, S = subtree (mirrored for large vs small)
___ ___
| P | | P |
_/_ _/_
| N | => | S |
_/_
| S |
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 |"
smaller := self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: freeTreeNode.
larger := self fetchPointer: self freeChunkLargerIndex ofFreeChunk: freeTreeNode.
parent := self fetchPointer: self freeChunkParentIndex ofFreeChunk: freeTreeNode.
parent = 0
ifTrue: "no parent; stitch the subnodes back into the root"
[smaller = 0
ifTrue:
+ [larger ~= 0 ifTrue:
+ [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0].
- [self storePointer: self freeChunkParentIndex ofFreeChunk: larger withValue: 0.
freeLists at: 0 put: larger]
ifFalse:
[self storePointer: self freeChunkParentIndex ofFreeChunk: smaller withValue: 0.
freeLists at: 0 put: smaller.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]
ifFalse: "parent; stitch back into appropriate side of parent."
[smaller = 0
ifTrue: [self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: larger.
larger ~= 0 ifTrue:
[self storePointer: self freeChunkParentIndex
ofFreeChunk: larger
withValue: parent]]
ifFalse:
[self storePointer: (freeTreeNode = (self fetchPointer: self freeChunkSmallerIndex ofFreeChunk: parent)
ifTrue: [self freeChunkSmallerIndex]
ifFalse: [self freeChunkLargerIndex])
ofFreeChunk: parent
withValue: smaller.
self storePointer: self freeChunkParentIndex
ofFreeChunk: smaller
withValue: parent.
larger ~= 0 ifTrue:
[self addFreeSubTree: larger]]]!
Item was changed:
----- Method: StackInterpreter>>checkIsStillMarriedContext:currentFP: (in category 'frame access') -----
checkIsStillMarriedContext: aContext currentFP: currentFP
+ "Another version of isWidowedContext: for debugging.
- "Another version of isWidowedContext:currentFP: for debugging.
This will not bereave a widowed context."
+ | thePage theFP limitFP frameCtxt |
- | thePage theFP limitFP |
<inline: false>
<var: #currentFP type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #theFP type: #'char *'>
<var: #limitFP type: #'char *'>
+ ((objectMemory isContext: aContext)
+ and: [self isMarriedOrWidowedContext: aContext]) ifFalse:
- (objectMemory isIntegerObject: (objectMemory fetchPointer: SenderIndex ofObject: aContext)) ifFalse:
[^false].
theFP := self frameOfMarriedContext: aContext.
thePage := stackPages stackPageFor: theFP.
limitFP := (thePage = stackPage and: [currentFP notNil])
ifTrue: [currentFP]
ifFalse: [thePage headFP].
+ (theFP >= limitFP
+ and: [(objectMemory isNonImmediate: (self frameCallerFP: theFP) asInteger)
+ and: [(self withSmallIntegerTags: (self frameCallerFP: theFP))
- ^theFP >= limitFP
- and: [(objectMemory isNonImmediate: (self frameCallerFP: theFP) asInteger)
- and: [(self withSmallIntegerTags: (self frameCallerFP: theFP))
= (objectMemory fetchPointer: InstructionPointerIndex ofObject: aContext)
+ and: [self frameHasContext: theFP]]]) ifFalse:
+ [^false].
+ frameCtxt := self frameContext: theFP.
+ (objectMemory isForwarded: frameCtxt) ifTrue:
+ [frameCtxt := objectMemory followForwarded: frameCtxt].
+ ^frameCtxt = aContext!
- and: [(self frameMethodObject: theFP)
- = (objectMemory fetchPointer: MethodIndex ofObject: aContext)
- and: [(self frameHasContext: theFP)
- and: [(self frameContext: theFP) = aContext
- and: [objectMemory isContext: aContext]]]]]]!
Item was changed:
----- Method: StackInterpreter>>checkStackIntegrity (in category 'object memory support') -----
checkStackIntegrity
"Perform an integrity/leak check using the heapMap. Assume
clearLeakMapAndMapAccesibleObjects has set a bit at each
object's header. Scan all objects accessible from the stack
checking that every pointer points to a header. Answer if no
dangling pointers were detected."
| ok |
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
ok := true.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP oop |
thePage := stackPages stackPageAt: i.
(stackPages isFree: thePage) ifFalse:
[thePage = stackPage
ifTrue:
[theSP := stackPointer.
theFP := framePointer]
ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP].
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage ifFalse:
[theSP := theSP + BytesPerWord].
[[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame temp' andFrame: theFP at: theSP.
ok := false].
theSP := theSP + BytesPerWord].
(self frameHasContext: theFP) ifTrue:
[oop := self frameContext: theFP.
((objectMemory isImmediate: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame ctxt' andFrame: theFP at: theFP + FoxThisContext.
ok := false].
(objectMemory isContext: oop) ifFalse:
[self printFrameThing: 'frame ctxt should be context' andFrame: theFP at: theFP + FoxThisContext.
+ ok := false].
+ ((objectMemory isContext: oop) and: [self isMarriedOrWidowedContext: oop]) ifFalse:
+ [self printFrameThing: 'frame ctxt should be married' andFrame: theFP at: theFP + FoxThisContext.
+ ok := false].
+ ((objectMemory isContext: oop)
+ and: [(self isMarriedOrWidowedContext: oop)
+ and: [(self frameOfMarriedContext: oop) = theFP]]) ifFalse:
+ [self printFrameThing: 'frame ctxt should be married to this frame ' andFrame: theFP at: theFP + FoxThisContext.
ok := false]].
oop := self frameMethod: theFP.
((objectMemory isImmediate: oop)
or: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame mthd' andFrame: theFP at: theFP + FoxMethod.
ok := false].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := theFP + FoxCallerSavedIP + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerSavedIP + BytesPerWord.
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
((objectMemory isNonImmediate: oop)
and: [(self heapMapAtWord: (self pointerForOop: oop)) = 0]) ifTrue:
[self printFrameThing: 'object leak in frame arg' andFrame: theFP at: theSP.
ok := false].
theSP := theSP + BytesPerWord]]].
^ok!
Item was changed:
----- Method: StackInterpreter>>isWidowedContext: (in category 'frame access') -----
isWidowedContext: aOnceMarriedContext
+ "See if the argument is married to a live frame or not.
- "See if the argument is connected with a live frame or not.
If it is not, turn it into a bereaved single context."
+ | theFrame thePage shouldBeFrameCallerField frameCtxt |
- | theFrame thePage shouldBeFrameCallerField |
<var: #theFrame type: #'char *'>
<var: #thePage type: #'StackPage *'>
<var: #shouldBeFrameCallerField type: #'char *'>
self assert: ((objectMemory isContext: aOnceMarriedContext)
and: [self isMarriedOrWidowedContext: aOnceMarriedContext]).
theFrame := self frameOfMarriedContext: aOnceMarriedContext.
thePage := stackPages stackPageFor: theFrame.
((stackPages isFree: thePage)
or: [theFrame < thePage headFP]) ifFalse:
["The frame pointer is within the bounds of a live page.
Now check if it matches a frame."
shouldBeFrameCallerField := self withoutSmallIntegerTags:
+ (objectMemory
+ fetchPointer: InstructionPointerIndex
+ ofObject: aOnceMarriedContext).
- (objectMemory fetchPointer: InstructionPointerIndex
- ofObject: aOnceMarriedContext).
((self frameCallerFP: theFrame) = shouldBeFrameCallerField
+ and: [self frameHasContext: theFrame]) ifTrue:
+ [frameCtxt := self frameContext: theFrame.
+ (objectMemory isForwarded: frameCtxt) ifTrue:
+ [frameCtxt := objectMemory followForwarded: frameCtxt.
+ self setFrameContext: theFrame to: frameCtxt].
+ frameCtxt = aOnceMarriedContext ifTrue: "It is still married!!"
+ [^false]]].
- and: [(self frameMethodObject: theFrame) = (objectMemory fetchPointer: MethodIndex
- ofObject: aOnceMarriedContext)
- and: [(self frameHasContext: theFrame)
- and: [(self frameContext: theFrame) = aOnceMarriedContext]]]) ifTrue:
- ["It is still married!!"
- ^false]].
"It is out of range or doesn't match the frame's context.
It is widowed. Time to wear black."
self markContextAsDead: aOnceMarriedContext.
^true!
Item was changed:
----- Method: StackInterpreter>>mapStackPages (in category 'object memory support') -----
mapStackPages
<inline: false>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #'char *'>
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP theIPPtr theIP oop |
thePage := stackPages stackPageAt: i.
thePage isFree ifFalse:
[theSP := thePage headSP.
theFP := thePage headFP.
"Skip the instruction pointer on top of stack of inactive pages."
thePage = stackPage
ifTrue: [theIPPtr := 0]
ifFalse:
[theIPPtr := theSP.
theSP := theSP + BytesPerWord].
[self assert: (thePage addressIsInPage: theFP).
self assert: (thePage addressIsInPage: theSP).
self assert: (theIPPtr = 0 or: [thePage addressIsInPage: theIPPtr]).
[theSP <= (theFP + FoxReceiver)] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
theSP := theSP + BytesPerWord].
+ (self frameHasContext: theFP) ifTrue:
+ [(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
+ [stackPages
+ longAt: theFP + FoxThisContext
+ put: (objectMemory remapObj: (self frameContext: theFP))].
+ self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
+ and: [(self frameOfMarriedContext: (self frameContext: theFP)) = theFP])].
- ((self frameHasContext: theFP)
- and: [objectMemory shouldRemapObj: (self frameContext: theFP)]) ifTrue:
- [stackPages
- longAt: theFP + FoxThisContext
- put: (objectMemory remapObj: (self frameContext: theFP))].
(objectMemory shouldRemapObj: (self frameMethod: theFP)) ifTrue:
[theIPPtr ~= 0 ifTrue:
[self assert: (stackPages longAt: theIPPtr) > (self frameMethod: theFP).
theIP := (stackPages longAt: theIPPtr) - (self frameMethod: theFP)].
stackPages
longAt: theFP + FoxMethod
put: (objectMemory remapObj: (self frameMethod: theFP)).
theIPPtr ~= 0 ifTrue:
[stackPages longAt: theIPPtr put: theIP + (self frameMethod: theFP)]].
(callerFP := self frameCallerFP: theFP) ~= 0] whileTrue:
[theSP := (theIPPtr := theFP + FoxCallerSavedIP) + BytesPerWord.
theFP := callerFP].
theSP := theFP + FoxCallerContext. "a.k.a. FoxCallerSavedIP"
[theSP <= thePage baseAddress] whileTrue:
[oop := stackPages longAt: theSP.
(objectMemory shouldRemapOop: oop) ifTrue:
[stackPages longAt: theSP put: (objectMemory remapObj: oop)].
theSP := theSP + BytesPerWord]]]!
Item was changed:
----- Method: StackInterpreter>>printFramesOnStackPageListInUse (in category 'debug printing') -----
printFramesOnStackPageListInUse
<export: true>
| page |
<inline: false>
<var: #page type: #'StackPage *'>
page := stackPages mostRecentlyUsedPage.
[(stackPages isFree: page) ifFalse:
+ [self print: 'page '; printHexPtrnp: (self cCode: [page] inSmalltalk: [page baseAddress]); cr.
- [self print: 'page '; printHexnp: page; cr.
self printFramesInPage: page.
self cr].
(page := page prevPage) ~= stackPages mostRecentlyUsedPage] whileTrue!
Item was changed:
----- Method: StackInterpreter>>shortPrintFramesOnStackPageListInUse (in category 'debug printing') -----
shortPrintFramesOnStackPageListInUse
<export: true>
| page |
<inline: false>
<var: #page type: #'StackPage *'>
page := stackPages mostRecentlyUsedPage.
[(stackPages isFree: page) ifFalse:
+ [self print: 'page '; printHexPtrnp: (self cCode: [page] inSmalltalk: [page baseAddress]); cr.
- [self print: 'page '; printHexnp: page; cr.
self shortPrintFramesInPage: page.
self cr].
(page := page prevPage) ~= stackPages mostRecentlyUsedPage] whileTrue!
Item was added:
+ ----- Method: StackInterpreterSimulator>>markContextAsDead: (in category 'frame access') -----
+ markContextAsDead: oop
+ "(self withoutSmallIntegerTags: (objectMemory fetchPointer: SenderIndex ofObject: oop)) = -16r26824 ifTrue:
+ [self halt]."
+ ^super markContextAsDead: oop!
More information about the Vm-dev
mailing list