[Vm-dev] VM Maker: VMMaker.oscog.seperateMarking-WoC.3295.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue Jan 10 23:52:56 UTC 2023
Tom Braun uploaded a new version of VMMaker to project VM Maker:
http://source.squeak.org/VMMaker/VMMaker.oscog.seperateMarking-WoC.3295.mcz
==================== Summary ====================
Name: VMMaker.oscog.seperateMarking-WoC.3295
Author: WoC
Time: 11 January 2023, 12:52:25.919544 am
UUID: 140f57bd-5c97-4644-8e87-1440a7610e2e
Ancestors: VMMaker.oscog.seperateMarking-WoC.3294
- Some performance optimizations for resolving polymorphism (especially the calculation of the transitive closure of methods)
- new method to define a list of methods to be resolved with the recursive polymorphism mechanism (and use it on 4 methods in StackInterpreter)
- counting marker now knows how many objects are in a segment
- CompactingSweeper now tries to stay in 5 ms runtime (sometimes it shoots over and some expensive security mechanism for developing add some massive time overhead, but otherwise it goes in a good direction)
- more debug printing and some debug texts reformatted
- removed unused Simulator classes
- added some methods to enable starting the simulator again (as there is not real class structure to switch between incremental and stop-the-world it is currently not running for incremental gc)
- enabled stop-the-world gc for snapshotting (have to investigate if it works correctly, but I was able to save and open an image without problems)
- added some debugging convenience methods
- fix bridge bug
=============== Diff against VMMaker.oscog.seperateMarking-WoC.3294 ===============
Item was changed:
----- Method: CCodeGenerator>>addPolymorphicVariantsFor:referencing:with:default: (in category 'helpers polymorphic resolving') -----
addPolymorphicVariantsFor: aTMethod referencing: variableName with: classArray default: defaultClass
| tMethod |
tMethod := methods at: aTMethod selector.
methods at: aTMethod selector put: (aTMethod asPolymorphicBaseFor: classArray toResolve: variableName default: defaultClass).
classArray
do: [:class | | copy polymorphicMethod |
+ "self halt."
"make a copy to make sure we get no side effects on the copies"
+ copy := tMethod fasterDeepCopy.
- copy := tMethod veryDeepCopy.
polymorphicMethod := copy asPolymorphicFor: variableName resolveTo: class.
(methods at: aTMethod selector ifAbsent: []) ifNotNil:
[:conflict |
((aTMethod definingClass inheritsFrom: conflict definingClass)
or: [aTMethod definingClass = conflict definingClass]) ifFalse:
[self error: 'Method name conflict: ', aTMethod selector]].
methods at: polymorphicMethod selector put: polymorphicMethod]!
Item was changed:
----- Method: CCodeGenerator>>hasPolymorphicMethod:in: (in category 'helpers polymorphic resolving') -----
hasPolymorphicMethod: aSelector in: aClass
+ "do we know the class direcly?"
+ recursivePolymorphicMethodsMap at: aClass
+ ifPresent: [:methodMap | (methodMap includes: aSelector)
+ ifTrue: [^ true]].
+
+ "do we now any if its superclasses"
+ ^ aClass allSuperclasses
- ^ aClass withAllSuperclasses
anySatisfy: [:class | (recursivePolymorphicMethodsMap at: class ifAbsent: [{}]) includes: aSelector]!
Item was changed:
----- Method: CCodeGenerator>>ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn:fromMethod:in: (in category 'public') -----
ifStaticallyResolvedPolymorphicReceiverThenUpdateSelectorIn: aSendNode fromMethod: aTMethod in: aClass
"We allow a limited amount of polymorphism; if a class chooses, its selectors can be
prefixed with a given string to disambiguate. This hack allows us to use two different
compaction algorithms with the same API at the same time; the selection being done
by a class which holds the flag stating which algorithm is in effect at the current time."
| class receiverSymbol |
staticallyResolvedPolymorphicReceivers ifNil: [^self].
+ "for debugging. Please do not remove!!"
+ "(aTMethod selector = #checkForEventsMayContextSwitch: and: [aSendNode selector = #sufficientSpaceAfterGC:]) ifTrue: [self halt]."
- "for debugging. Please do not remove!!"
- "(aTMethod selector = #slidingCompactionRemapObj: and: [aSendNode selector = #isMobile:]) ifTrue: [self halt]."
(aSendNode receiver isVariable
or: [(self hasPolymorphicMethod: aSendNode selector in: aClass )
or: [removedForPolymorphism includesKey: aSendNode selector]])
ifFalse: [^self].
+ receiverSymbol := aSendNode receiver name.
- receiverSymbol := aSendNode receiver name.
+ (aTMethod pragmasAt: #staticallyResolveMessagesTo:asIfCalledIn:)
+ ifNotNil: [:pragmas |
+ pragmas
+ detect: [:pragma | receiverSymbol = (pragma argumentAt: 1)]
+ ifFound: [:pragma |
+ "methods at: aSendNode selector."
+ self halt.]
+ ifNone: []].
+
class := (aTMethod pragmasAt: #staticallyResolveMethod:to:)
ifNotNil: [:pragmas |
pragmas
detect: [:pragma | aSendNode selector = (pragma argumentAt: 1)]
ifFound: [:pragma | "self halt."
self
resolve: aSendNode
to: (Smalltalk at: (pragma argumentAt: 2))
ifFound: [^self]]
ifNone: []].
class := (aTMethod pragmaAt: #declareTypeForStaticPolymorphism:)
ifNotNil: [:pragma | | typeHint classFromHint |
typeHint := pragma argumentAt: 1.
classFromHint := Smalltalk at: (pragma argumentAt: 1).
"if we look at a polymorphic base method do not resolve it to its default but the type hint if it knows it"
methods at: aSendNode selector
ifPresent: [:method |
method isPolymorphicBase
ifTrue: [(method classes includes: classFromHint)
ifTrue: [ | newSelector |
newSelector := method polymorphicSelectorForClass: classFromHint.
aSendNode setSelectorForPolymorphism: newSelector.
^ self]].
method isPolymorphic
ifTrue: [self error: 'Should not happen']].
removedForPolymorphism at: aSendNode selector
ifPresent: [:dictionary |
dictionary at: classFromHint
ifPresent: [:selector |
aSendNode
setSelectorForPolymorphism: selector.
^ self].
(mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = classFromHint]) keys
detect: [:key | dictionary includesKey: key]
ifFound: [:clazz |
aSendNode
setSelectorForPolymorphism: (dictionary at: clazz).
^ self]
]].
class ifNil: [self resolveRecursivePolymorphism: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: [^ self]].
class := class ifNil: [self getClassFromPragmasIn: aTMethod ifMatching: receiverSymbol].
class := class ifNil: [self getClassFor: receiverSymbol in: aClass].
class := class ifNil: [
removedForPolymorphism at: aSendNode selector
ifPresent: [: dict |
"you probably ask yourself: why am I here? This halt is triggered if we were unable to resolve your method, although
it is polymorphic with a very high probability. You either have to declare to which type the method has to be resolved, you
did not implement to method in the class you would it expect to be in (inspect dict and see if the class you would expect is
listed there as a key. If not you did not call staticallyResolveMethodNamed:forClass:to: on the selector in the missing class, please
investigate) or I forgot to include one case if the type should already be known
Please have a look what aTMethod to know in which method the problem occured and aSendNode to know the call in aTMethod that is not enough defined. Probably you want to include a pragma #staticallyResolveReceiver:to: to define of which type the receiver is. Should the current method be a Polymorphic(Base)TMethod it is probably interesting why resolveRecursivePolymorphism:in:fromMethod:in:ifMatch: above does not resolve it."
+
+ "
+ For easier debugging:
+ Browser fullOnClass: aTMethod definingClass selector: aTMethod selector.
+ "
+
+ self error: 'Could not resolve: ' , aSendNode asString , ' in: ' , aTMethod asString
+ , '. Possible variants of the methods exist in: ' , dict associations asString]].
- self halt]].
"we have to find a class to resolve the selector"
class
ifNotNil: [
aSendNode
setSelectorForPolymorphism: (class staticallyResolvePolymorphicSelector: aSendNode selector)]
!
Item was added:
+ ----- Method: CCodeGenerator>>recursivelyResolvePolymorpicReceiver:toVariants:in:default:forMethodList: (in category 'public') -----
+ recursivelyResolvePolymorpicReceiver: variableName toVariants: classArray in: aClass default: defaultClass forMethodList: aMethodCollection
+ "We allow a limited amount of polymorphism; if a class chooses, its selectors can be
+ prefixed with a given string to disambiguate. This hack allows us to use two different
+ compaction algorithms with the same API at the same time; the selection being done
+ by a class which holds the flag stating which algorithm is in effect at the current time."
+ ((recursivelyResolvedPolymorphicReceivers ifNil: [recursivelyResolvedPolymorphicReceivers := Dictionary new])
+ at: aClass
+ ifAbsentPut: [Dictionary new])
+ at: variableName
+ put: classArray.
+
+ aMethodCollection do: [:selector | methods
+ at: selector
+ ifPresent: [:method |
+ (recursivePolymorphicMethodsMap ifNil: [recursivePolymorphicMethodsMap := Dictionary new])
+ at: aClass
+ ifPresent: [:set | set add: method selector]
+ ifAbsentPut: [Set with: method selector].
+ self
+ addPolymorphicVariantsFor: method
+ referencing: variableName
+ with: classArray
+ default: defaultClass]
+ ifAbsent: []].!
Item was changed:
----- Method: CCodeGenerator>>resolvePolymorphicMethod:in:fromMethod:in:ifMatch: (in category 'helpers polymorphic resolving') -----
resolvePolymorphicMethod: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock
self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: aTMethod receiverClass ifFound: aReturnBlock.
receiverSymbol = aTMethod receiverToResolve
ifTrue: [self resolve: aSendNode to: aTMethod receiverClass ifFound: aReturnBlock].
"now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context"
removedForPolymorphism at: aSendNode selector
ifPresent: [:dictionary | dictionary at: aTMethod receiverClass
ifPresent: [:selector |
aSendNode
setSelectorForPolymorphism: selector.
aReturnBlock value].
"is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?"
(mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = aTMethod receiverClass]) keys
+ detect: [:key | dictionary keys anySatisfy: [:ea | key includesBehavior: ea]]
+ ifFound: [:class | | actualClass |
+ actualClass := dictionary keys detect: [:ea | class includesBehavior: ea].
- detect: [:key | dictionary includesKey: key]
- ifFound: [:class |
aSendNode
+ setSelectorForPolymorphism: (dictionary at: actualClass).
- setSelectorForPolymorphism: (dictionary at: class).
aReturnBlock value]].
(self hasPolymorphicMethod: aSendNode selector in: aTMethod receiverClass)
ifTrue: [self halt]!
Item was changed:
----- Method: CCodeGenerator>>resolveRecursivePolymorphism:in:fromMethod:in:ifMatch: (in category 'helpers polymorphic resolving') -----
resolveRecursivePolymorphism: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock
"- if the current TMethod is a base method we want to resolve it to the default
- if the current TMethod is a polymorphic method, meaning it got a type to resolve for, apply this type to submethods
- if the called method (from SendNode) is a polymorphic base method we resolve it to the default if we are not in a class associated with only one type. Should this be the case we resolve the method to this type"
"((aTMethod selector = #globalGarbageCollect) and: [aSendNode selector = #preGlobalGCActions]) ifTrue: [0 halt]."
aTMethod isPolymorphicBase
ifTrue: [self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: aTMethod default ifFound: aReturnBlock.
"if the polymorphic receiver is mentioned we resolve the method to the default"
self resolve: aSendNode to: aTMethod default ifFound: aReturnBlock.
"now get desperate. look if there is a method with the selectors name that is mentioned in a polymorphic context"
removedForPolymorphism at: aSendNode selector
ifPresent: [:dictionary | dictionary at: aTMethod default
ifPresent: [:selector |
aSendNode
setSelectorForPolymorphism: selector.
aReturnBlock value].
"is the TMethods receiverClass associated with one of the polymorphic classes implementing aSendNode selector?"
(mappingForRecursivePolymophism associationsSelect: [:assoc | assoc value = aTMethod default]) keys
+ detect: [:key | dictionary keys anySatisfy: [:ea | key includesBehavior: ea]]
+ ifFound: [:class | | actualClass |
+ actualClass := dictionary keys detect: [:ea | class includesBehavior: ea].
+ aSendNode
+ setSelectorForPolymorphism: (dictionary at: actualClass).
+ aReturnBlock value]].
+
- detect: [:key | dictionary includesKey: key]
- ifFound: [:class |
- aSendNode
- setSelectorForPolymorphism: (dictionary at: class).
- aReturnBlock value]].
-
(self hasPolymorphicMethod: aSendNode selector in: aTMethod default)
ifTrue: [self halt]].
aTMethod isPolymorphic
ifTrue: [self resolvePolymorphicMethod: receiverSymbol in: aSendNode fromMethod: aTMethod in: aClass ifMatch: aReturnBlock].
methods at: aSendNode selector
ifPresent: [:calledMethod |
calledMethod isPolymorphicBase
ifTrue: [ | alternativeClass matchingClass |
"we have type info and the calledMethod does not care which type it is -> use type info"
aTMethod isPolymorphic
ifTrue: [
aSendNode
setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: aTMethod receiverClass).
aReturnBlock value ].
"should we or one of our superclasses define the called method use the default because we call it ourself and there is no other info"
self resolve: receiverSymbol inSelfSend: aSendNode in: aClass to: calledMethod default ifFound: aReturnBlock.
"should the class be mapped to a fixed type use it to resolve the type of the method"
alternativeClass := mappingForRecursivePolymophism at: aClass ifAbsent: [nil].
(calledMethod classes includes: aClass)
ifTrue: [matchingClass := aClass]
ifFalse: [(calledMethod classes includes: alternativeClass)
ifTrue: [matchingClass := alternativeClass]].
matchingClass ifNotNil: [
aSendNode
setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: matchingClass).
aReturnBlock value].
"we have no info about the method, but we know it is a polymorphic base -> resolve to default because we assume everyone wants the default"
Transcript show: 'Resolved ' , aSendNode asString.
aSendNode setSelectorForPolymorphism: (calledMethod polymorphicSelectorForClass: calledMethod default).
Transcript
show: ' to ' , aSendNode asString , ' in ' , aTMethod asString , ' because it is the default for the defined polymorphic method.';
cr.
aReturnBlock value
]]
ifAbsent: [] .
!
Item was changed:
----- Method: CCodeGenerator>>transitiveClosureOfMethods:in: (in category 'helpers polymorphic resolving') -----
transitiveClosureOfMethods: aTMethodDictionary in: aClass
+ | alreadySeenSelectors toVisit toVisitNext classes mappingSendsToSelectors |
- | alreadySeenSelectors toVisit toVisitNext |
alreadySeenSelectors := Set newFrom: aTMethodDictionary keys.
toVisit := OrderedCollection newFrom: aTMethodDictionary keys.
toVisitNext := OrderedCollection new.
+
+ mappingSendsToSelectors := Dictionary new.
+ classes := (aClass withAllSuperclasses copyUpTo: VMClass).
+
+ classes do: [:ea |
+ ea selectorsAndMethodsDo: [:selector :method |
+
+ method
+ selectorsDo: [:sel |
+ mappingSendsToSelectors
+ at: sel
+ ifPresent: [:collection | collection add: selector]
+ ifAbsentPut: [OrderedCollection with: selector]]]].
+
+ mappingSendsToSelectors.
+
+ [toVisit do: [:ea |
+ mappingSendsToSelectors at: ea
+ ifPresent: [:collection | collection
+ do: [:sender |
+ (alreadySeenSelectors includes: sender)
+ ifFalse: [alreadySeenSelectors add: sender.
+ toVisitNext add: sender]]]].
+ toVisit := toVisitNext.
+ toVisitNext := OrderedCollection new.
+
+ toVisit notEmpty] whileTrue.
+
+
+
+ "old much slower code. When tested for StackInterpreter there were 3 methods difference. From a first glance I
+ could not determine why they should be included, but should the future show I simply overlooked something here the
+ old code for reference
+
+ [toVisit
+ do: [:each | (SystemNavigation default allCallsOn: each fromBehaviors: (aClass withAllSuperclasses copyUpTo: VMClass) sorted: false)
- [toVisit
- do: [:each | (SystemNavigation default allCallsOn: each fromBehaviors: (aClass withAllSuperclasses copyUpTo: VMClass )sorted: false)
do: [:method | |selector |
selector := method selector.
(alreadySeenSelectors includes: selector)
+ ifFalse: [
+ selector = #getenv: ifTrue: [self halt].
+ alreadySeenSelectors add: selector.
- ifFalse: [alreadySeenSelectors add: selector.
toVisitNext add: selector] ]].
toVisit := toVisitNext.
toVisitNext := OrderedCollection new.
+ toVisit notEmpty] whileTrue."
- toVisit notEmpty] whileTrue.
^ alreadySeenSelectors!
Item was changed:
+ ----- Method: PolymorphicBaseTMethod>>printOn: (in category 'printing') -----
- ----- Method: PolymorphicBaseTMethod>>printOn: (in category 'as yet unclassified') -----
printOn: aStream
super printOn: aStream.
aStream
nextPut: $<;
nextPutAll: self default name;
nextPut: $>!
Item was changed:
TMethod subclass: #PolymorphicTMethod
+ instanceVariableNames: 'receiverToResolve receiverClass oldSelector'
- instanceVariableNames: 'receiverToResolve receiverClass'
classVariableNames: ''
poolDictionaries: ''
category: 'VMMaker-Translation to C'!
Item was added:
+ ----- Method: PolymorphicTMethod>>oldSelector (in category 'accessing') -----
+ oldSelector
+
+ ^ oldSelector!
Item was added:
+ ----- Method: PolymorphicTMethod>>oldSelector: (in category 'accessing') -----
+ oldSelector: anObject
+
+ oldSelector := anObject.!
Item was changed:
+ ----- Method: PolymorphicTMethod>>printOn: (in category 'printing') -----
- ----- Method: PolymorphicTMethod>>printOn: (in category 'as yet unclassified') -----
printOn: aStream
super printOn: aStream.
aStream
nextPut: $<;
nextPutAll: self receiverClass name;
nextPut: $>!
Item was added:
+ ----- Method: PolymorphicTMethod>>smalltalkSelector (in category 'as yet unclassified') -----
+ smalltalkSelector
+
+ ^ oldSelector!
Item was added:
+ ----- Method: PolymorphicTMethod>>unmodifiedSelector (in category 'as yet unclassified') -----
+ unmodifiedSelector
+ "I am not sure if any of the other selector accesses are overloaded or used otherwise in the system
+ -> I write this to be extra sure it is only used where I want it to be used"
+
+ ^ self oldSelector!
Item was added:
+ ----- Method: SpurCountingIncrementalMarker>>getLifeObjectCountOf: (in category 'segment occupation') -----
+ getLifeObjectCountOf: segInfo
+
+ <var: 'segInfo' type: #'SpurSegmentInfo *'>
+
+ "hack: use lastFreeObject (only used during snapshot, where GC is already done and we can ignore that it gets changed) to keep track of
+ how much life data is in the segment"
+ ^ self
+ cCode: [segInfo savedSegSize]
+ inSmalltalk: [segInfo savedSegSize ifNil: [0]]!
Item was changed:
----- Method: SpurCountingIncrementalMarker>>getUsedMemoryOf: (in category 'segment occupation') -----
getUsedMemoryOf: segInfo
<var: 'segInfo' type: #'SpurSegmentInfo *'>
"hack: use lastFreeObject (only used during snapshot, where GC is already done and we can ignore that it gets changed) to keep track of
how much life data is in the segment"
+ ^ self
+ cCode: [segInfo lastFreeObject]
+ inSmalltalk: [segInfo lastFreeObject ifNil: [0]]!
- ^ segInfo lastFreeObject!
Item was changed:
----- Method: SpurCountingIncrementalMarker>>initForNewMarkingPass (in category 'marking-initialization') -----
initForNewMarkingPass
super initForNewMarkingPass.
0 to: manager numSegments - 1
+ do: [:index | | segInfo |
+ segInfo := manager segInfoAt: index.
+ self
+ setUsedMemory: 0 for: segInfo;
+ setLifeObjectCount: 0 for: segInfo]!
- do: [:index |
- self setUsedMemory: 0 for: (manager segInfoAt: index)]!
Item was changed:
----- Method: SpurCountingIncrementalMarker>>setIsMarkedOf: (in category 'header access') -----
setIsMarkedOf: objOop
| segmentContainingObject |
super setIsMarkedOf: objOop.
self flag: #Todo. "we need a more efficient way to get the segment"
segmentContainingObject := manager segmentManager segmentContainingObj: objOop.
+
self
setUsedMemory: (self getUsedMemoryOf: segmentContainingObject) + (manager bytesInBody: objOop)
+ for: segmentContainingObject.
+
+ self
+ setLifeObjectCount: (self getLifeObjectCountOf: segmentContainingObject) + 1
for: segmentContainingObject!
Item was added:
+ ----- Method: SpurCountingIncrementalMarker>>setLifeObjectCount:for: (in category 'segment occupation') -----
+ setLifeObjectCount: objectCount for: segInfo
+
+ <var: 'segInfo' type: #'SpurSegmentInfo *'>
+
+ "hack: use savedSegSize (only used during snapshot, where GC is already done and we can ignore that it gets changed) to keep track of
+ how much life objects are in the segment"
+ segInfo savedSegSize: objectCount!
Item was changed:
CogClass subclass: #SpurGarbageCollector
instanceVariableNames: 'marker scavenger compactor manager coInterpreter allocatorShouldAllocateBlack'
classVariableNames: ''
+ poolDictionaries: 'SpurMemoryManagementConstants VMSpurObjectRepresentationConstants'
- poolDictionaries: 'SpurMemoryManagementConstants'
category: 'VMMaker-SpurGarbageCollector'!
Item was changed:
----- Method: SpurIncremental2PhaseGarbageCollector>>doIncrementalCollect (in category 'as yet unclassified') -----
doIncrementalCollect
| startTime |
phase = InMarkingPhase
ifTrue: [ | finishedMarking |
marker isCurrentlyMarking
ifFalse: [self assert: manager allObjectsUnmarked].
coInterpreter cr; print: 'start marking '; tab; flush.
finishedMarking := marker incrementalMarkObjects.
"self assert: manager validObjectColors."
finishedMarking
ifTrue: [
"manager allPastSpaceObjectsDo: [:obj | self assert: (manager isWhite: obj)]."
"when sweeping the mutator needs to allocate new objects black as we do not have any information about them.
We only know if they should get swept after the next marking -> keep them alive for this cycle"
self allocatorShouldAllocateBlack: true.
compactor setInitialSweepingEntity.
phase := InSweepingPhase.
"marking is done and thus all forwarding from the last compaction references are resolved
-> we can use the now free segments that were compacted during the last cycle"
compactor freePastSegmentsAndSetSegmentToFill.
compactor assertNoSegmentBeingCompacted.
self assert: manager noObjectGrey.
coInterpreter cr; print: 'finish marking '; tab; flush.
startTime := coInterpreter ioUTCMicrosecondsNow.
manager
setCheckForLeaks: GCCheckFreeSpace + GCModeFull;
runLeakCheckerFor: GCModeFull excludeUnmarkedObjs: true classIndicesShouldBeValid: true;
checkFreeSpace: GCModeFull.
+ manager clearLeakMapAndMapMarkedOrYoungObjects.
+ coInterpreter checkStackIntegrity.
+
coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush.
0 to: manager numSegments - 1
do: [:i | | segInfo |
segInfo := manager segInfoAt: i.
coInterpreter cr; print: 'occupation from marking: '; printNum: (compactor occupationOf: segInfo) * 100; tab;
+ print: '('; printNum: (marker getLifeObjectCountOf: segInfo); print: ' objects -> ' ;printNum: (compactor sizeClaimedIn: segInfo) ; print: ' bytes)' ;flush].
- print: '('; printNum: (compactor sizeClaimedIn: segInfo) ; print: ' bytes)' ;flush].
manager printSegmentOccupationFromMarkedObjects.
^ self]
ifFalse: [coInterpreter cr; print: 'finish marking pass'; tab; flush. "manager runLeakCheckerFor: GCModeIncremental"]].
phase = InSweepingPhase
ifTrue: [
coInterpreter cr; print: 'start sweeping '; tab; flush.
compactor incrementalSweepAndCompact
ifTrue: [
self allocatorShouldAllocateBlack: false.
self assert: manager allObjectsWhite.
"self assert: manager allObjectsUnmarked."
coInterpreter cr; print: 'finish sweeping '; tab; flush.
startTime := coInterpreter ioUTCMicrosecondsNow.
manager
setCheckForLeaks: GCCheckFreeSpace + GCModeFull;
runLeakCheckerFor: GCModeFull;
checkFreeSpace: GCModeFull.
coInterpreter cr; print: 'time for internal check: '; printNum: coInterpreter ioUTCMicrosecondsNow - startTime; tab; flush.
phase := InMarkingPhase.
^ self]]!
Item was changed:
SpurCompactor subclass: #SpurIncrementalCompactingSweeper
+ instanceVariableNames: 'isCurrentlyWorking currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge currentObject segmentToFill shouldCompact currentCopyToPointer scStartTime maxObjectsToFree'
+ classVariableNames: 'InitialMaxObjectsToFree MaxOccupationForCompaction MinObjectToFree'
- instanceVariableNames: 'isCurrentlyWorking currentSegmentsIndex currentsCycleSeenObjectCount currentSegmentsBridge currentObject segmentToFill shouldCompact currentCopyToPointer scStartTime'
- classVariableNames: 'MaxObjectsToFree MaxOccupationForCompaction'
poolDictionaries: ''
category: 'VMMaker-SpurGarbageCollector'!
!SpurIncrementalCompactingSweeper commentStamp: 'WoC 1/5/2023 23:21' prior: 0!
A SpurIncrementalCompactingSweeper is an incremental sweeper that compacts too. It is a merge of SpurIncrementalSweeper and SpurIncrementalCompactor with slight changes to the algorithm to accomodate
to the fact both parts run at the same time. It traverses the heap one time sweeps normal segments, compacts segments that are planned to be compacted (more on that later) and skips the segment that should get filled. The compaction is adapted from: Lazy Pointer Update for Low Heap Compaction Pause Times (Clément Béra; Eliot Miranda; Elisa Gonzalez Boix -> https://doi.org/10.1145/3359619.3359741)
The SpurIncrementalCompactingSweeper is designed to run after the SpurCountingIncrementalMarker. The SpurCountingIncrementalMarker will write how many bytes of life data are in segments into the segmentInfo lastFreeObject. As a first step we decide if and when yes which segments should get compacted. We try to compact as many segments as possible, that are under a certain threshold (see MaxOccupationForCompaction what the actual value is), into the segmentToFill (an completetly empty segment we reserve or allocate when no empty segment is available)
The interesting entry point for understanding the algorithm is doincrementalSweepAndCompact. We already planned the compaction (read from planCompactionAndReserveSpace) and reserved the segmentToFill (freePastSegmentsAndSetSegmentToFill or findOrAllocateSegmentToFill). We now scan the whole heap. When the current object is in a normal segment we just do a normal sweep. This includes unmarking marked objects and coalescing unmarked objects and free chunks to larger free chunks (the whole succession of free chunks and unmarked objects until the next marked object or end of segment (attention!! only until the end of the segment the first object of this succession is)).
Should the current object we see be in the segmentToFill we skip the whole segment. We can safely skip it as it was empty previously (the mutator cannot allocate into the segmentToFill) and we only copy life objects here -> we do not need to do work here as everything here is life.
If the current object is in a segment that should be compacted (the current object will then be at the beginning of the segment) we start to compact it into segmentToFill. Free chunks get detached and set to a different class (so other safety mechanism ignore them). Marked objects get unmarked and forwarded to the segmentToFill. Unmarked objects get ignored (we just unremember them).
Instance Variables
currentCopyToPointer: <Object>
currentObject: <Object>
currentSegmentsBridge: <Object>
currentSegmentsIndex: <Object>
currentsCycleSeenObjectCount: <Object>
isCurrentlyWorking: <Object>
segmentToFill: <Object>
shouldCompact: <Object>
currentCopyToPointer
- xxxxx
currentObject
- xxxxx
currentSegmentsBridge
- xxxxx
currentSegmentsIndex
- xxxxx
currentsCycleSeenObjectCount
- xxxxx
isCurrentlyWorking
- xxxxx
segmentToFill
- xxxxx
shouldCompact
- xxxxx
!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
+ aCCodeGenerator
+ var: #segmentToFill type: #'SpurSegmentInfo *';
+ var: 'maxObjectsToFree' declareC: 'sqInt maxObjectsToFree = ', InitialMaxObjectsToFree asString.
- aCCodeGenerator var: #segmentToFill type: #'SpurSegmentInfo *'.
SpurMemoryManager wantsIncrementalGC
ifTrue: [
(self selectors intersection: SpurPlanningCompactor selectors)
do: [:key |
aCCodeGenerator
staticallyResolveMethodNamed: key
forClass: self
to: (self staticallyResolvePolymorphicSelector: key)]]!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper class>>initialize (in category 'initialization') -----
initialize
super initialize.
"If the segment is occupied by more than MaxOccupationForCompaction,
it's not worth compacting it, whatever the rest of the system looks like.
MaxOccupationForCompaction is included in [0;16rFFFF]."
MaxOccupationForCompaction := 16rD000. "81%"
+
+ "a wild guesses"
+ MinObjectToFree := 1000.
+ InitialMaxObjectsToFree := 100000!
- MaxObjectsToFree := 100000!
Item was added:
+ ----- Method: SpurIncrementalCompactingSweeper>>calculateNextMaxObjectToFreeBasedOn: (in category 'sweep and compact') -----
+ calculateNextMaxObjectToFreeBasedOn: runTime
+
+ ^ (maxObjectsToFree / (runTime asFloat / 5000)) max: MinObjectToFree!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>cautiousBulkFreeChunkFrom: (in category 'incremental sweeping') -----
cautiousBulkFreeChunkFrom: objOop
"The old space entity before objOop is necessarily a marked object. Attempts to free as many bytes
from objOop start as possible, looking ahead to free contiguous freechunks / unmarked objects"
| bytes start next currentObj |
self assert: (self canUseAsFreeSpace: objOop).
start := manager startOfObject: objOop.
currentObj := objOop.
bytes := 0.
[bytes := bytes + (manager bytesInBody: currentObj).
(manager isRemembered: currentObj)
ifTrue:
[self assert: (manager isFreeObject: currentObj) not.
scavenger forgetObject: currentObj].
(manager isFreeObject: currentObj)
ifTrue: [ "we need to unlink chunks for concurrent sweeping. In the stop the world sweeper we can just reset the freeLists but here we need to keep them
around so the mutator can still work between sweeping passes"
self flag: #Todo. "we want to optimize for lilliputian chunks!! For now it is ok(ish) but we have to do something about it.
At the moment I see 3 possibilities:
- have the lilliputian list always sorted (O(n) insert in the worst case!!)
- sort the lilliputian part before sweeping (O(n log n) at the start. but everytime before sweeping)
- be cheeky and discard the lilliputian list (problem: the mutator has no access to the list + it can insert unsorted chunks (for the duration of sweeping we could let it use a second list and just append it after sweeping)"
manager detachFreeObject: currentObj.
"self assert: manager totalFreeOldSpace = manager totalFreeListBytes."].
next := manager objectStartingAt: start + bytes.
currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1.
self assert: ((manager oop: next isLessThan: manager endOfMemory)
or: [next = manager endOfMemory and: [(self canUseAsFreeSpace: next) not]]).
"should the next object not be usable as free space (because it is marked) abort the loop. Attention:
briges at the end of segments are marked and therefore we leave the loop here. This is important as the
newly created free space segment should not be bigger than there still is space left in the current segment"
+ (self canUseAsFreeSpace: next) and: [currentsCycleSeenObjectCount < maxObjectsToFree]]
- (self canUseAsFreeSpace: next) and: [currentsCycleSeenObjectCount < MaxObjectsToFree]]
whileTrue: [currentObj := next].
^ manager addFreeChunkWithBytes: bytes at: start!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>compactSegment:freeStart:segIndex: (in category 'incremental compact') -----
compactSegment: segInfo freeStart: initialFreeStart segIndex: segIndex
<var: 'segInfo' type: #'SpurSegmentInfo *'>
| fillStart |
fillStart := initialFreeStart.
self deny: segIndex = 0. "Cannot compact seg 0"
manager segmentManager
allEntitiesInSegment: segInfo
exceptTheLastBridgeDo:
[:entity |
(manager isFreeObject: entity)
ifTrue:
[manager detachFreeObject: entity.
+ currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1.
"To avoid confusing too much Spur (especially the leak/free checks), we mark the free chunk as a word object."
manager set: entity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat]
ifFalse:
[ (manager isMarked: entity)
ifTrue: [manager makeWhite: entity.
"During the mutator runs new forwarding references can be created. Ignore them as they get resolved with the other
forwarders in this segment in the next marking pass"
(manager isForwarded: entity)
ifFalse:[| bytesToCopy |
"Copy the object in segmentToFill and replace it by a forwarder."
bytesToCopy := manager bytesInBody: entity.
(self would: fillStart + bytesToCopy overflowSegment: segmentToFill)
ifFalse: [
self handleWouldBeCompactionOverflow: entity in: segInfo.
^ fillStart].
+
+ "let's make copying more expensive. Number is just a guess"
+ currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 100.
-
self migrate: entity sized: bytesToCopy to: fillStart.
fillStart := fillStart + bytesToCopy.
self assert: (self oop: fillStart isLessThan: (segmentToFill segLimit - manager bridgeSize))]]
ifFalse: [self handleUnmarkedEntity: entity]]].
"we want to advance to the next segment from the bridge"
currentObject := currentSegmentsBridge.
^ fillStart!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>doincrementalSweepAndCompact (in category 'sweep and compact') -----
doincrementalSweepAndCompact
"Scan the heap for unmarked objects and free them. Coalescence "
self assert: currentObject notNil.
currentsCycleSeenObjectCount := 0.
[self oop: currentObject isLessThan: manager endOfMemory] whileTrue:
[ currentObject = currentSegmentsBridge
ifTrue: [self advanceSegment]
ifFalse: [self sweepOrCompactFromCurrentObject].
- (currentObject ~= currentSegmentsBridge and: [currentsCycleSeenObjectCount >= MaxObjectsToFree])
- ifTrue: [" | segInfo segIndex bytesAhead |
- segIndex := (manager segmentIndexContainingObj: currentObject).
- segInfo := manager segInfoAt: segIndex.
-
- bytesAhead := segInfo segSize - (currentObject - segInfo segStart).
-
- segIndex + 1 to: manager numSegments
- do: [:index | | segment|
- segment := manager segInfoAt: index.
- bytesAhead := bytesAhead + segment segSize]."
-
-
-
- (coInterpreter ioUTCMicrosecondsNow - scStartTime) > 5000
- ifTrue: [^ false]
- ifFalse: [currentsCycleSeenObjectCount := 0]]].
+ "coInterpreter cr;
+ print: 'Arrived: ';
+ printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab;
+ print: ' -> '; printNum: currentsCycleSeenObjectCount."
+ (currentObject ~= currentSegmentsBridge and: [currentsCycleSeenObjectCount >= maxObjectsToFree])
+ ifTrue: [| runTime |
+ runTime := (coInterpreter ioUTCMicrosecondsNow - scStartTime).
+ runTime > 5000
+ ifTrue: [
+ maxObjectsToFree := self calculateNextMaxObjectToFreeBasedOn: runTime.
+
+ coInterpreter cr;
+ print: 'Time in sweep and compact: ';
+ printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab;
+ print: 'maxObjectsToFree now: '; printNum: maxObjectsToFree; tab; flush.
+ ^ false]
+ ifFalse: [
+ maxObjectsToFree := self calculateNextMaxObjectToFreeBasedOn: runTime.
+ currentsCycleSeenObjectCount := 0]]].
+
+ coInterpreter cr;
+ print: 'Time in sweep and compact: ';
+ printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab; flush.
+
- "set occupation for last segment"
manager checkFreeSpace: GCModeIncremental.
+ manager heapMap clearLeakMapAndMapAccessibleObjects.
+ coInterpreter checkStackIntegrity.
+
^ true!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>handleUnmarkedEntity: (in category 'compaction planning') -----
handleUnmarkedEntity: entity
(manager isRemembered: entity)
ifTrue:
[self assert: (manager isFreeObject: entity) not.
scavenger forgetObject: entity].
"To avoid confusing too much Spur (especially the leak/free checks), we don't make the dead object a free chunk, but make it
a non pointer object to avoid the leak checker to try to follow the pointers of the dead object.
Should we abort compacting this segment the object will get kept alife for one gc cycle"
+ manager set: entity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat.
+
+ currentsCycleSeenObjectCount := currentsCycleSeenObjectCount + 1.!
- manager set: entity classIndexTo: manager wordSizeClassIndexPun formatTo: manager wordIndexableFormat!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>incrementalSweepAndCompact (in category 'api') -----
incrementalSweepAndCompact
scStartTime := coInterpreter ioUTCMicrosecondsNow.
self initIfNecessary.
"should in between sweeper calls segments be removed the index would not be correct anymore. Reset it here so we can be sure it is correct"
currentSegmentsIndex := manager segmentManager segmentIndexContainingObj: currentObject.
"if the bridge between segments was small before and the segment directly after the current one was removed the position of the bridge moved. Update
the current position to avoid this case"
currentSegmentsBridge := manager segmentManager bridgeAt: currentSegmentsIndex.
+ " so expensive :(
+ self assert: manager validObjectColors."
- self assert: manager validObjectColors.
+ coInterpreter cr;
+ print: 'Starting up ';
+ printNum: coInterpreter ioUTCMicrosecondsNow - scStartTime ; tab.
+
self doincrementalSweepAndCompact
ifTrue: [self finishSweepAndCompact.
^ true].
"do not end on a bridge!! If a segment behind the current one currentObject is removed the size of the bridge can change from 8 bytes to 16 bytes and
therefore invalidating currentObject that is now pointing to the overflow header instad of the bridges body. To not hove to implement some finicky update
mechanism in the removal of segments just make sure we never reference the bridge before giving back the control to the mutator"
self assert: (manager isSegmentBridge: currentObject) not.
"skip empty segments. There is no work for us to do + they can be removed. As currentObject is always in the current segment
it won't be valid anymore"
self assert: (manager segmentManager isEmptySegment: self currentSegment) not.
coInterpreter cr; print: 'current position: '; printHex: currentObject; tab; flush.
^ false!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>initialize (in category 'initialize-release') -----
initialize
isCurrentlyWorking := false.
currentSegmentsIndex := 0.
currentsCycleSeenObjectCount := 0.
currentSegmentsBridge := nil.
currentObject := nil.
segmentToFill := nil.
shouldCompact := false.
+ currentCopyToPointer := nil.
+ maxObjectsToFree := MaxObjectsToFree!
- currentCopyToPointer := nil!
Item was changed:
+ ----- Method: SpurIncrementalCompactingSweeper>>isMobile: (in category 'testing') -----
- ----- Method: SpurIncrementalCompactingSweeper>>isMobile: (in category 'as yet unclassified') -----
isMobile: obj
<inline: true>
self flag: #Todo. "investigate this one here"
^ (manager isPinned: obj) not!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>setFreeChunkOfCompactedIntoSegment (in category 'incremental compact') -----
setFreeChunkOfCompactedIntoSegment
shouldCompact ifFalse: [^ self].
self assert: segmentToFill notNil.
self assert: (self oop: currentCopyToPointer isLessThan: (segmentToFill segLimit - manager bridgeSize)).
+ coInterpreter cr;
+ print: 'after compaction freeing from: '; printHex: currentCopyToPointer;
+ print: ' to: '; printHex: segmentToFill segSize - manager bridgeSize + segmentToFill segStart - currentCopyToPointer ;
+ tab; flush.
+
manager
addFreeChunkWithBytes: segmentToFill segSize - manager bridgeSize + segmentToFill segStart - currentCopyToPointer
at: currentCopyToPointer.
"we have compacted into segmentToFill. It is now not empty anymore and we need to look for a new one"
segmentToFill := nil
!
Item was changed:
+ ----- Method: SpurIncrementalCompactingSweeper>>setInitialSweepingEntity (in category 'incremental sweeping') -----
- ----- Method: SpurIncrementalCompactingSweeper>>setInitialSweepingEntity (in category 'as yet unclassified') -----
setInitialSweepingEntity
currentObject := manager firstObject!
Item was changed:
+ ----- Method: SpurIncrementalCompactingSweeper>>sizeClaimedIn: (in category 'segment access') -----
- ----- Method: SpurIncrementalCompactingSweeper>>sizeClaimedIn: (in category 'as yet unclassified') -----
sizeClaimedIn: segment
<var: 'segment' type: #'SpurSegmentInfo *'>
^ segment lastFreeObject!
Item was changed:
----- Method: SpurIncrementalCompactingSweeper>>sweepOrCompactFromCurrentObject (in category 'sweep and compact') -----
sweepOrCompactFromCurrentObject
self shouldCompactCurrentSegment
ifTrue: [self doIncrementalCompact.
"either we finished compacting the segment or we had to abort compaction as the segment to fill cannot take more objects from this segment. We have to continue sweeping. This is done by unmarking the current segment as beeing compacted and making sure the last object we nearly copied before (and we know was alive after marking) is kept alive for sweeping"
self assert: ((manager isSegmentBridge: currentObject)
+ or: [(manager isMarked: currentObject)
+ and: [(self isSegmentAtIndexBeingCompacted: currentSegmentsIndex) not]])]
- or: [(manager isMarked: currentObject) and: [(self isSegmentAtIndexBeingCompacted: currentSegmentsIndex) not]]).
-
- (coInterpreter ioUTCMicrosecondsNow - scStartTime) > 5000
- ifTrue: ["we just compacted a whole segment. Maybe this took a long time therefore set currentsCycleSeenObjectCount to max to force a check in doincrementalSweepAndCompact"
- currentsCycleSeenObjectCount := MaxObjectsToFree]]
ifFalse: [self doIncrementalSweep.
currentObject := self nextCurrentObject]
!
Item was changed:
SpurGarbageCollector subclass: #SpurIncrementalGarbageCollector
+ instanceVariableNames: 'phase allAtOnceMarker checkSetGCFlags stopTheWorldGC'
- instanceVariableNames: 'phase allAtOnceMarker checkSetGCFlags'
classVariableNames: 'InCompactingPhase InMarkingPhase InSweepingPhase'
poolDictionaries: ''
category: 'VMMaker-SpurGarbageCollector'!
!SpurIncrementalGarbageCollector commentStamp: 'WoC 1/5/2023 21:36' prior: 0!
A SpurIncrementalGarbageCollector is a garbage collection algorithm. The GC is a mark and sweep with an additional compaction if certain conditions are fulfilled.
This class manages SpurIncrementalMarker and SpurIncrementalSweepAndCompact (which in turn manages SpurIncrementalCompactor and SpurIncrementalSweeper). The 3 classes
implementing the GC are therefore SpurIncrementalMarker, SpurIncrementalSweeper and SpurIncrementalCompactor.
Instance Variables
allAtOnceMarker: <SpurAllAtOnceMarker>
checkSetGCFlags: <Bool>
phase: <Number (InMarkingPhase|InSweepingPhase|InCompactingPhase)>
allAtOnceMarker
- an instance of SpurAllAtOnceMarker. We sometimes need parts of the old (stop-the-world) gc algorithm. This is the marking algorithm we can use through static polymorphism
checkSetGCFlags
- should we check if it ok to set gc flags or not
phase
- in which phase is the gc algorithm at the moment. Is either InMarkingPhase, InSweepingPhase or InCompactingPhase
!
Item was changed:
----- Method: SpurIncrementalGarbageCollector class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
super declareCVarsIn: aCCodeGenerator.
aCCodeGenerator
var: 'phase' declareC: 'sqInt phase = 0';
var: 'checkSetGCFlags' declareC: 'sqInt checkSetGCFlags = 1'.
aCCodeGenerator
+ staticallyResolvedPolymorphicReceiver: 'allAtOnceMarker' to: SpurAllAtOnceMarker in: self;
+ staticallyResolvedPolymorphicReceiver: 'stopTheWorldGC' to: SpurStopTheWorldGarbageCollector in: self.
- staticallyResolvedPolymorphicReceiver: 'allAtOnceMarker' to: SpurAllAtOnceMarker in: self.
SpurMemoryManager gcClass = self
ifTrue: [
self declareRecursivePolymorphismMappingForIncrementalClasses: aCCodeGenerator.
"just important when doiing incremental compaction, therefore doin it here"
aCCodeGenerator
forRecursivePolymorphismResolve: SpurAllAtOnceMarker as: SpurStopTheWorldGarbageCollector;
forRecursivePolymorphismResolve: SpurPlanningCompactor as: SpurStopTheWorldGarbageCollector].
!
Item was added:
+ ----- Method: SpurIncrementalGarbageCollector>>coInterpreter: (in category 'accessing') -----
+ coInterpreter: anObject
+
+ <doNotGenerate>
+ coInterpreter := anObject.
+ allAtOnceMarker coInterpreter: anObject!
Item was added:
+ ----- Method: SpurIncrementalGarbageCollector>>doScavengeWithoutIncrementalCollect: (in category 'scavenge') -----
+ doScavengeWithoutIncrementalCollect: tenuringCriterion
+
+ super doScavengeWithoutIncrementalCollect: tenuringCriterion.
+
+ coInterpreter resolveForwardersInStackPages.!
Item was added:
+ ----- Method: SpurIncrementalGarbageCollector>>gcForSnapshot (in category 'as yet unclassified') -----
+ gcForSnapshot
+
+ self finishGCPass.
+ coInterpreter cr; print: 'finished incremental gc pass'; tab; flush.
+
+ stopTheWorldGC fullGC.
+ coInterpreter cr; print: 'finished stop the world gc'; tab; flush.
+ !
Item was changed:
----- Method: SpurIncrementalGarbageCollector>>initialize (in category 'initialize-release') -----
initialize
super initialize.
checkSetGCFlags := true.
phase := InMarkingPhase.
+ allAtOnceMarker := SpurAllAtOnceMarker new.
+ stopTheWorldGC := SpurStopTheWorldGarbageCollector new.
+
+ stopTheWorldGC marker: allAtOnceMarker.
+ stopTheWorldGC compactor: SpurPlanningCompactor new!
- allAtOnceMarker := SpurAllAtOnceMarker new!
Item was added:
+ ----- Method: SpurIncrementalGarbageCollector>>isInSegmentToFill: (in category 'as yet unclassified') -----
+ isInSegmentToFill: objOop
+
+ ^ compactor segmentToFill notNil and: [manager segmentManager is: objOop inSegment: compactor segmentToFill]!
Item was changed:
----- Method: SpurIncrementalGarbageCollector>>isOkToClearReference: (in category 'testing') -----
isOkToClearReference: objOop
+ "when using incremental GC if an object is dead is only possible to determine in a small time window (in sweeping for objects behind the sweepers position). During marking the information is not complete and in compaction the mark bits are already cleared. For simplicity, forbid clearing them.
- "when using incremental GC if an object is life is only possible to determine in a small time window (in sweeping for objects behind the sweepers position). During marking the information is not complete and in compaction the mark bits are already cleared. For simlicity, forbid clearing them.
Now only at the end of marking weak references and ephermerons get cleared (in old and young space)"
^ (manager isOldObject: objOop) not!
Item was added:
+ ----- Method: SpurIncrementalGarbageCollector>>manager: (in category 'accessing') -----
+ manager: anObject
+
+ <doNotGenerate>
+ manager := anObject.
+ allAtOnceMarker manager: anObject !
Item was added:
+ ----- Method: SpurIncrementalGarbageCollector>>numSegmentsAboutToBeFreed (in category 'as yet unclassified') -----
+ numSegmentsAboutToBeFreed
+
+ | result |
+ result := 0.
+
+ "start at 1 as segment 0 never gets compacted by design"
+ 1 to: manager numSegments - 1
+ do: [:index |
+ (compactor isSegmentBeingCompacted: (manager segInfoAt: index))
+ ifTrue: [result := result + 1]].
+
+ ^ result!
Item was changed:
----- Method: SpurIncrementalGarbageCollector>>sufficientSpaceAfterGC: (in category 'as yet unclassified') -----
sufficientSpaceAfterGC: numBytes
| heapSizePostGC |
self assert: numBytes = 0.
self scavengingGCTenuringIf: TenureByAge.
heapSizePostGC := manager segmentManager totalOldSpaceCapacity - manager totalFreeOldSpace.
(heapSizePostGC - manager heapSizeAtPreviousGC) asFloat / manager heapSizeAtPreviousGC >= manager heapGrowthToSizeGCRatio
ifTrue: ["self fullGC"] "fullGC will attempt to shrink"
ifFalse: "Also attempt to shrink if there is plenty of free space and no need to GC"
[manager totalFreeOldSpace > (manager shrinkThreshold * 2) ifTrue:
[manager attemptToShrink.
^true]].
+
+ self flag: #Todo. "we probably want here something more sophisticated, like tak into account how many
+ objects survived tenuring in the near past and how much work is still to be done until marking is finished
+ and the segments get freed. Until then just assume the compacted segments get freed soon enough"
+ [self numSegmentsAboutToBeFreed = 0 "lets wait until we get more space"
+ and: [manager totalFreeOldSpace < manager growHeadroom
+ and: [(manager growOldSpaceByAtLeast: 0) notNil]]] whileTrue:
- [manager totalFreeOldSpace < manager growHeadroom
- and: [(manager growOldSpaceByAtLeast: 0) notNil]] whileTrue:
[manager totalFreeOldSpace >= manager growHeadroom ifTrue:
[^true]].
manager lowSpaceThreshold > manager totalFreeOldSpace ifTrue: "space is low"
[manager lowSpaceThreshold: 0. "avoid signalling low space twice"
^false].
^true!
Item was changed:
----- Method: SpurIncrementalGarbageCollector>>writeBarrierFor:at:with: (in category 'barrier') -----
writeBarrierFor: anObject at: index with: value
"a dijkstra style write barrier with the addition of the generation check
objects that are not able to contain pointers are ignored too, as the write barries
should ensure we lose no references and this objects do not hold any of them"
<inline: true>
self flag: #Todo. "we probably want the oldObject check to be the first one as it is only a pointer comparison and no dereferencing is needed"
"((manager isImmediate: value) not and: [(manager isPureBitsNonImm: value)])
ifTrue: [coInterpreter cr; print: 'saw: '; printHexnp: value; tab; flush]."
self flag: #Todo. "do I need the immediate check?"
+ (self isMarking and: [(manager isImmediate: value) not and: [(manager isOldObject: anObject) and: [(manager isOldObject: value) and: [manager isMarked: anObject]]]])
- (self marking and: [(manager isImmediate: value) not and: [(manager isOldObject: anObject) and: [(manager isOldObject: value) and: [manager isMarked: anObject]]]])
ifTrue: [marker markAndShouldScan: value]!
Item was removed:
- SpurIncrementalGarbageCollector subclass: #SpurIncrementalGarbageCollectorSimulator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'VMMaker-SpurGarbageCollectorSimulation'!
Item was removed:
- ----- Method: SpurIncrementalGarbageCollectorSimulator>>doIncrementalCollect (in category 'as yet unclassified') -----
- doIncrementalCollect
-
- | context |
- manager statScavenges \\ 50 = 0 ifTrue: [GCEventLog reset].
- "(manager statScavenges > 218 and: [phase = InSweepingPhase]) ifTrue: [self halt]."
- "manager statScavenges = 320 ifTrue: [self halt]."
-
- "pop mutator context"
- context := GCEventLog instance popContext.
- self assert: (context kind = #mutator or: [context kind = #fullGC]).
- super doIncrementalCollect.
-
- context kind = #fullGC
- ifTrue: [GCEventLog instance pushContext: context]
- ifFalse: [GCEventLog instance pushMutatorContext]
- !
Item was removed:
- ----- Method: SpurIncrementalGarbageCollectorSimulator>>fullGC (in category 'global') -----
- fullGC
-
- GCEventLog
- inContext: #fullGC
- do: [super fullGC]!
Item was removed:
- ----- Method: SpurIncrementalGarbageCollectorSimulator>>initialize (in category 'initialize-release') -----
- initialize
-
- super initialize.
- GCEventLog reset!
Item was removed:
- ----- Method: SpurIncrementalGarbageCollectorSimulator>>manager: (in category 'accessing') -----
- manager: manager
-
- super manager: manager.
- GCEventLog instance manager: manager!
Item was removed:
- SpurIncrementalMarker subclass: #SpurIncrementalMarkerSimulator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'VMMaker-SpurGarbageCollectorSimulation'!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>blackenObject: (in category 'as yet unclassified') -----
- blackenObject: obj
-
- ^ GCEventLog
- register: (GCBlackenEvent address: obj)
- expecting: {[:evt | (evt isKindOf: GCUngreyEvent) and: [evt address = obj]].
- [:evt | (evt isKindOf: GCMarkEvent) and: [evt address = obj]]}
- doing: [super blackenObject: obj]!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>finishMarking (in category 'as yet unclassified') -----
- finishMarking
-
- ^ GCEventLog
- inContext: #finishMarking
- do: [super finishMarking]!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>incrementalMark (in category 'marking - incremental') -----
- incrementalMark
-
- ^ GCEventLog
- inContext: #IncrementalMark
- do: [super incrementalMark]!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>incrementalMarkObjects (in category 'marking - incremental') -----
- incrementalMarkObjects
-
- ^ GCEventLog
- inContext: #marking
- do: [super incrementalMarkObjects]!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>initForNewMarkingPassIfNecessary (in category 'marking-initialization') -----
- initForNewMarkingPassIfNecessary
-
- ^ GCEventLog
- inContext: #markingInit
- do: [super initForNewMarkingPassIfNecessary]!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>pushAllRootsOnMarkStack (in category 'root-scanning') -----
- pushAllRootsOnMarkStack
-
- GCEventLog
- inContext: #rootScanning
- do: [super pushAllRootsOnMarkStack] !
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>pushExtraRootsReferencesOnMarkingStack (in category 'root-scanning') -----
- pushExtraRootsReferencesOnMarkingStack
-
- GCEventLog
- inContext: #extraRootScanning
- do: [super pushExtraRootsReferencesOnMarkingStack] !
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>pushHiddenRootsReferencesOnMarkingStack (in category 'root-scanning') -----
- pushHiddenRootsReferencesOnMarkingStack
-
- GCEventLog
- inContext: #hiddenRootScanning
- do: [super pushHiddenRootsReferencesOnMarkingStack] !
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>pushNewSpaceReferencesOnMarkingStack (in category 'root-scanning') -----
- pushNewSpaceReferencesOnMarkingStack
-
- GCEventLog
- inContext: #newSpaceScanning
- do: [super pushNewSpaceReferencesOnMarkingStack]!
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>pushOnMarkingStackAndMakeGrey: (in category 'marking-stack') -----
- pushOnMarkingStackAndMakeGrey: obj
-
- super pushOnMarkingStackAndMakeGrey: obj
- !
Item was removed:
- ----- Method: SpurIncrementalMarkerSimulator>>pushStackReferencesOnMarkingStack (in category 'root-scanning') -----
- pushStackReferencesOnMarkingStack
-
- GCEventLog
- inContext: #stackScanning
- do: [super pushStackReferencesOnMarkingStack]!
Item was changed:
+ ----- Method: SpurIncrementalSweepAndCompact>>biasForSnapshot (in category 'api') -----
- ----- Method: SpurIncrementalSweepAndCompact>>biasForSnapshot (in category 'as yet unclassified') -----
biasForSnapshot!
Item was added:
+ ----- Method: SpurIncrementalSweepAndCompact>>isCurrentlyCompacting (in category 'as yet unclassified') -----
+ isCurrentlyCompacting
+
+ <doNotGenerate>
+ ^ compactor isCurrentlyCompacting!
Item was added:
+ ----- Method: SpurIncrementalSweepAndCompact>>isSegmentBeingCompacted: (in category 'as yet unclassified') -----
+ isSegmentBeingCompacted: segInfo
+
+ <doNotGenerate>
+ ^ compactor isSegmentBeingCompacted: segInfo !
Item was changed:
+ ----- Method: SpurIncrementalSweepAndCompact>>manager: (in category 'initialization') -----
- ----- Method: SpurIncrementalSweepAndCompact>>manager: (in category 'as yet unclassified') -----
manager: manager
<doNotGenerate>
super manager: manager.
sweeper manager: manager.
compactor manager: manager!
Item was removed:
- SpurIncrementalSweepAndCompact subclass: #SpurIncrementalSweepAndCompactSimulator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'VMMaker-SpurGarbageCollectorSimulation'!
Item was removed:
- ----- Method: SpurIncrementalSweepAndCompactSimulator>>incrementalCompact (in category 'api - incremental') -----
- incrementalCompact
-
- ^ GCEventLog
- inContext: #compact
- do: [super incrementalCompact]
- !
Item was removed:
- ----- Method: SpurIncrementalSweepAndCompactSimulator>>incrementalSweep (in category 'api - incremental') -----
- incrementalSweep
-
- ^ GCEventLog
- inContext: #sweep
- do: [super incrementalSweep]
- !
Item was removed:
- SpurIncrementalSweeper subclass: #SpurIncrementalSweeperSimulator
- instanceVariableNames: ''
- classVariableNames: ''
- poolDictionaries: ''
- category: 'VMMaker-SpurGarbageCollectorSimulation'!
Item was removed:
- ----- Method: SpurIncrementalSweeperSimulator>>canUseAsFreeSpace: (in category 'as yet unclassified') -----
- canUseAsFreeSpace: objOop
-
- "objOop = 16r25FDBD8 ifTrue: [self halt]."
- ^ super canUseAsFreeSpace: objOop!
Item was removed:
- ----- Method: SpurIncrementalSweeperSimulator>>doIncrementalSweeping (in category 'api - incremental') -----
- doIncrementalSweeping
-
- ^ GCEventLog
- inContext: #doIncrementalSweep
- do: [super doIncrementalSweeping]!
Item was removed:
- ----- Method: SpurIncrementalSweeperSimulator>>finishSweeping (in category 'as yet unclassified') -----
- finishSweeping
-
- ^ GCEventLog
- inContext: #finishSweeping
- do: [super finishSweeping]!
Item was removed:
- ----- Method: SpurIncrementalSweeperSimulator>>incrementalSweep (in category 'api - incremental') -----
- incrementalSweep
-
- ^ GCEventLog
- inContext: #incrementalSweep
- do: [super incrementalSweep]!
Item was removed:
- ----- Method: SpurIncrementalSweeperSimulator>>initIfNecessary (in category 'api - incremental') -----
- initIfNecessary
-
- ^ GCEventLog
- inContext: #sweepInit
- do: [super initIfNecessary]!
Item was removed:
- ----- Method: SpurIncrementalSweeperSimulator>>unmark: (in category 'api') -----
- unmark: objOop
-
- super unmark: objOop
- "^ GCEventLog
- register: (GCWhitenEvent address: objOop)
- expecting: {
- [:evt | evt = (GCUnmarkEvent address: objOop)].
- [:evt | evt = (GCUngreyEvent address: objOop)]}
- doing: [super unmark: objOop]"!
Item was changed:
----- Method: SpurMemoryManager class>>isNonArgumentImplicitReceiverVariableName: (in category 'translation') -----
isNonArgumentImplicitReceiverVariableName: aString
+ ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap' 'marker' 'sweeper' 'gc' 'allAtOnceMarker' 'stopTheWorldGC') includes: aString!
- ^#('self' 'coInterpreter' 'manager' 'scavenger' 'segmentManager' 'compactor' 'planningCompactor' 'selectiveCompactor' 'heapMap' 'marker' 'sweeper' 'gc' 'allAtOnceMarker') includes: aString!
Item was changed:
----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrityForIncrementalGC (in category 'debug support') -----
checkHeapFreeSpaceIntegrityForIncrementalGC
"Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace
has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points
to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass.
Ignore unmarked objects during sweeping"
| ok total |
<inline: false>
<var: 'total' type: #usqInt>
ok := true.
total := 0.
0 to: self numFreeLists - 1 do:
[:i|
(freeLists at: i) ~= 0 ifTrue:
[(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue:
[coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); eekcr.
ok := false]]].
"Excuse the duplication but performance is at a premium and we avoid
some tests by splitting the newSpace and oldSpace enumerations."
self allNewSpaceEntitiesDo:
[:obj| | fieldOop |
(self isFreeObject: obj)
ifTrue:
[coInterpreter print: 'young object '; printHex: obj; print: ' is free'; eekcr.
ok := false]
ifFalse:
[obj ~= freeSpaceCheckOopToIgnore ifTrue:
+ [0 to: (self numPointerSlotsOf: (self followMaybeForwarded: obj)) - 1 do:
- [0 to: (self numPointerSlotsOf: obj) - 1 do:
[:fi|
fieldOop := self fetchPointer: fi ofObject: obj.
(self isNonImmediate: fieldOop) ifTrue:
[(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue:
[coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr.
ok := false]]]]]].
self allOldSpaceEntitiesDo:
[:obj| | fieldOop |
(self isFreeObject: obj)
ifTrue:
[
+ (gc isInSegmentToFill: obj) not
- (compactor compactor segmentToFill isNil or: [(self objectStartingAt: (compactor compactor segmentToFill segStart)) ~= obj])
ifTrue: [
(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; eekcr.
ok := false].
fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj.
(fieldOop ~= 0
and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr.
ok := false].
(self isLilliputianSize: (self bytesInBody: obj)) ifFalse:
[fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj.
(fieldOop ~= 0
and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr.
ok := false]].
(self isLargeFreeObject: obj) ifTrue:
[self freeChunkParentIndex to: self freeChunkLargerIndex do:
[:fi|
fieldOop := self fetchPointer: fi ofFreeChunk: obj.
(fieldOop ~= 0
and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; eekcr.
ok := false]]].
total := total + (self bytesInBody: obj)]]
ifFalse:
[(obj ~= freeSpaceCheckOopToIgnore and:
"during sweeping ignore unmarked objects behind the current sweeping position"
[(gc inSweepingAheadOfSweepersPosition: obj) not or: [self isMarked: obj]]) ifTrue:
[0 to: (self numPointerSlotsOf: obj) - 1 do:
[:fi|
(self isForwarded: obj)
ifTrue:
[self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..."
fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj]
ifFalse: "We keep #fetchPointer:ofObject: API here for assertions"
[fieldOop := self fetchPointer: fi ofObject: obj].
(self isNonImmediate: fieldOop) ifTrue:
[(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue:
[coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr.
ok := false]]]]]].
total - totalFreeOldSpace ~= 0 ifTrue:
[coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; eekcr.
ok := false].
^ok!
Item was changed:
----- Method: SpurMemoryManager>>checkHeapFreeSpaceIntegrityForStopTheWorldGC (in category 'debug support') -----
checkHeapFreeSpaceIntegrityForStopTheWorldGC
"Perform an integrity/leak check using the heapMap. Assume clearLeakMapAndMapAccessibleFreeSpace
has set a bit at each free chunk's header. Scan all objects in the heap checking that no pointer points
to a free chunk and that all free chunks that refer to others refer to marked chunks. Answer if all checks pass."
| ok total |
<inline: false>
<var: 'total' type: #usqInt>
ok := true.
total := 0.
0 to: self numFreeLists - 1 do:
[:i|
(freeLists at: i) ~= 0 ifTrue:
[(heapMap heapMapAtWord: (self pointerForOop: (freeLists at: i))) = 0 ifTrue:
[coInterpreter print: 'leak in free list '; printNum: i; print: ' to non-free '; printHex: (freeLists at: i); eekcr.
ok := false]]].
"Excuse the duplication but performance is at a premium and we avoid
some tests by splitting the newSpace and oldSpace enumerations."
self allNewSpaceEntitiesDo:
[:obj| | fieldOop |
(self isFreeObject: obj)
ifTrue:
[coInterpreter print: 'young object '; printHex: obj; print: ' is free'; eekcr.
ok := false]
ifFalse:
[obj ~= freeSpaceCheckOopToIgnore ifTrue:
[0 to: (self numPointerSlotsOf: obj) - 1 do:
[:fi|
fieldOop := self fetchPointer: fi ofObject: obj.
(self isNonImmediate: fieldOop) ifTrue:
[(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue:
[coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr.
ok := false]]]]]].
self allOldSpaceEntitiesDo:
[:obj| | fieldOop |
(self isFreeObject: obj)
ifTrue:
[
+ (gc isInSegmentToFill: obj) not
- (compactor compactor segmentToFill isNil or: [(self objectStartingAt: (compactor compactor segmentToFill segStart)) ~= obj])
ifTrue: [
(heapMap heapMapAtWord: (self pointerForOop: obj)) = 0 ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' is unmapped?!! '; eekcr.
ok := false].
fieldOop := self fetchPointer: self freeChunkNextIndex ofFreeChunk: obj.
(fieldOop ~= 0
and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr.
ok := false].
(self isLilliputianSize: (self bytesInBody: obj)) ifFalse:
[fieldOop := self fetchPointer: self freeChunkPrevIndex ofFreeChunk: obj.
(fieldOop ~= 0
and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ 0 = '; printHex: fieldOop; print: ' is unmapped'; eekcr.
ok := false]].
(self isLargeFreeObject: obj) ifTrue:
[self freeChunkParentIndex to: self freeChunkLargerIndex do:
[:fi|
fieldOop := self fetchPointer: fi ofFreeChunk: obj.
(fieldOop ~= 0
and: [(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) = 0]) ifTrue:
[coInterpreter print: 'leak in free chunk '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is unmapped'; eekcr.
ok := false]]].
total := total + (self bytesInBody: obj)]]
ifFalse:
[obj ~= freeSpaceCheckOopToIgnore ifTrue:
[0 to: (self numPointerSlotsOf: obj) - 1 do:
[:fi|
(self isForwarded: obj)
ifTrue:
[self assert: fi = 0. "I'm now trying to use forwarders in GC algorithms..."
fieldOop := self fetchPointer: fi ofMaybeForwardedObject: obj]
ifFalse: "We keep #fetchPointer:ofObject: API here for assertions"
[fieldOop := self fetchPointer: fi ofObject: obj].
(self isNonImmediate: fieldOop) ifTrue:
[(heapMap heapMapAtWord: (self pointerForOop: fieldOop)) ~= 0 ifTrue:
[coInterpreter print: 'object leak in '; printHex: obj; print: ' @ '; printNum: fi; print: ' = '; printHex: fieldOop; print: ' is free'; eekcr.
ok := false]]]]]].
total - totalFreeOldSpace ~= 0 ifTrue:
[coInterpreter print: 'incorrect totalFreeOldSpace; expected '; printNum: totalFreeOldSpace; print: ' found '; printNum: total; eekcr.
ok := false].
^ok!
Item was changed:
----- Method: SpurMemoryManager>>checkHeapIntegrity:classIndicesShouldBeValid: (in category 'debug support') -----
(excessive size, no diff calculated)
Item was added:
+ ----- Method: SpurMemoryManager>>clearLeakMapAndMapInSweepingLifeOrYoungObjects (in category 'debug support - leak/mark map') -----
+ clearLeakMapAndMapInSweepingLifeOrYoungObjects
+ "Perform an integrity/leak check using the heapMap. Set a bit at each object's header."
+ <inline: false>
+ heapMap clearHeapMap.
+ self allObjectsDo:
+ [:oop|( (self isMarked: oop) or: [(self isYoung: oop) or: [oop < gc compactor currentObject]]) ifTrue: [heapMap heapMapAtWord: (self pointerForOop: oop) Put: 1]]!
Item was added:
+ ----- Method: SpurMemoryManager>>clearLeakMapAndMapMarkedObjects (in category 'debug support - leak/mark map') -----
+ clearLeakMapAndMapMarkedObjects
+ "Perform an integrity/leak check using the heapMap. Set a bit at each object's header."
+ <inline: false>
+ heapMap clearHeapMap.
+ self allObjectsDo:
+ [:oop| (self isMarked: oop) ifTrue: [heapMap heapMapAtWord: (self pointerForOop: oop) Put: 1]]!
Item was added:
+ ----- Method: SpurMemoryManager>>clearLeakMapAndMapMarkedOrYoungObjects (in category 'debug support - leak/mark map') -----
+ clearLeakMapAndMapMarkedOrYoungObjects
+ "Perform an integrity/leak check using the heapMap. Set a bit at each object's header."
+ <inline: false>
+ heapMap clearHeapMap.
+ self allObjectsDo:
+ [:oop|( (self isMarked: oop) or: [self isYoung: oop] )ifTrue: [heapMap heapMapAtWord: (self pointerForOop: oop) Put: 1]]!
Item was changed:
----- Method: SpurMemoryManager>>garbageCollectForSnapshot (in category 'snapshot') -----
garbageCollectForSnapshot
self flushNewSpace. "There is no place to put newSpace in the snapshot file."
self flag: 'If we wanted to shrink the rememberedSet prior to snapshot this is the place to do it.'.
compactor biasForSnapshot.
+ gc gcForSnapshot.
- self fullGC.
compactor biasForGC.
segmentManager prepareForSnapshot.
self checkFreeSpace: GCModeFull!
Item was changed:
----- Method: SpurMemoryManager>>growOldSpaceByAtLeast: (in category 'growing/shrinking memory') -----
growOldSpaceByAtLeast: minAmmount
"Attempt to grow memory by at least minAmmount.
Answer the size of the new segment, or nil if the attempt failed."
| ammount headroom total start interval |
<var: #segInfo type: #'SpurSegmentInfo *'>
"statGrowMemory counts attempts, not successes."
+
+ "self debugger."
statGrowMemory := statGrowMemory + 1."we need to include overhead for a new object header plus the segment bridge."
ammount := minAmmount + (self baseHeaderSize * 2 + self bridgeSize).
"round up to the nearest power of two."
ammount := 1 << (ammount - 1) highBit.
"and grow by at least growHeadroom."
ammount := ammount max: growHeadroom.
"Now apply the maxOldSpaceSize limit, if one is in effect."
maxOldSpaceSize > 0 ifTrue:
[total := segmentManager totalBytesInSegments.
total >= maxOldSpaceSize ifTrue:
[needGCFlag := true.
^nil].
headroom := maxOldSpaceSize - total.
headroom < ammount ifTrue:
[headroom < (minAmmount + (self baseHeaderSize * 2 + self bridgeSize)) ifTrue:
[needGCFlag := true.
^nil].
ammount := headroom]].
start := coInterpreter ioUTCMicrosecondsNow.
^(segmentManager addSegmentOfSize: ammount)
ifNil: [needGCFlag := true. nil]
ifNotNil:
[:segInfo|
self assimilateNewSegment: segInfo.
"and add the new free chunk to the free list; done here
instead of in assimilateNewSegment: for the assert"
self addFreeChunkWithBytes: segInfo segSize - self bridgeSize at: segInfo segStart.
self assert: (self addressAfter: (self objectStartingAt: segInfo segStart))
= (segInfo segLimit - self bridgeSize).
self checkFreeSpace: GCCheckFreeSpace.
segmentManager checkSegments.
interval := coInterpreter ioUTCMicrosecondsNow - start.
interval > statMaxAllocSegmentTime ifTrue: [statMaxAllocSegmentTime := interval].
segInfo segSize]!
Item was added:
+ ----- Method: SpurMemoryManager>>printFreeSpaceStatisticsWithUnmarkedAsFreeSpace (in category 'debug printing') -----
+ printFreeSpaceStatisticsWithUnmarkedAsFreeSpace
+
+ "used for debugging"
+ <export: true>
+ <var: 'sizeCount' declareC:'static unsigned long long sizeCount[64] = {0}'>
+
+ | sizeCount |
+ self cCode:'' inSmalltalk:[
+ sizeCount := CArrayAccessor on: (DoubleWordArray new: 64).
+ ].
+
+ coInterpreter cr;
+ print: '----------------------------------------- '; cr;
+ print: '----------------------------------------- ';
+ cr.
+
+ 0 to: self numSegments -1
+ do: [:index | | segInfo bigFreeChunkMemory freeSpace occupiedSpace objectCount |
+ segInfo := self segInfoAt: index.
+ bigFreeChunkMemory := 0.
+ freeSpace := 0.
+ occupiedSpace := 0.
+ objectCount := 0.
+
+
+ segmentManager
+ allEntitiesInSegment: segInfo
+ exceptTheLastBridgeDo: [:oop | | oopSize slotCount |
+ oopSize := self bytesInBody: oop.
+ slotCount := oopSize >> 3.
+
+ (self isFreeOop: oop)
+ ifTrue: [
+ freeSpace := freeSpace + oopSize.
+
+ slotCount < 64
+ ifTrue: [
+ sizeCount at: slotCount put: ((sizeCount at: slotCount) + 1)]
+ ifFalse: [sizeCount at: 0 put: ((sizeCount at: 0) + 1).
+ bigFreeChunkMemory := bigFreeChunkMemory + oopSize]]
+ ifFalse: [objectCount := objectCount + 1.
+ occupiedSpace := occupiedSpace + oopSize]].
+
+ coInterpreter cr;
+ print: 'Segment ';
+ printNum: index;
+ print: ' (starting at: ';
+ printHex: segInfo segStart; tab;
+ print: 'max bytes: '; tab;
+ printNum: segInfo segSize;
+ print: ')';
+ cr; cr; flush.
+
+ coInterpreter cr;
+ print: 'Currently occupied space: '; tab;
+ printNum: occupiedSpace; tab;
+ print: 'From '; printNum: objectCount; print: ' objects'; cr;
+ print: 'Currently free space: '; tab;
+ printNum: freeSpace; cr;
+ print: 'Resulting in an occupation percentage of: '; tab;
+ printNum: (occupiedSpace asFloat / (occupiedSpace + freeSpace)) * 100;
+ cr; cr; flush.
+
+ coInterpreter tab;
+ print: 'big free chunks ';
+ printNum: (sizeCount at: 0);
+ print: ' reserving number of bytes: ';
+ printNum: bigFreeChunkMemory;
+ cr; flush.
+ sizeCount at: 0 put: 0.
+
+
+ 1 to: 63
+ do: [:i |
+ (sizeCount at: i) > 0
+ ifTrue: [coInterpreter tab;
+ print: 'free chunk of size '; printNum: i; print: ': ';
+ printNum: (sizeCount at: i);
+ cr; flush.
+ sizeCount at: i put: 0.]].
+
+ coInterpreter cr;
+ print: '----------------------------------------- '; cr.].
+
+ coInterpreter cr;
+ print: '----------------------------------------- '; cr;
+ print: '----------------------------------------- ';
+ cr.
+ !
Item was changed:
----- Method: SpurMemoryManager>>printSegmentOccupationFromMarkedObjects (in category 'debug printing') -----
printSegmentOccupationFromMarkedObjects
"used for debugging"
<export: true>
coInterpreter cr;
print: '----------------------------------------- '; cr;
print: '----------------------------------------- ';
cr.
0 to: self numSegments -1
+ do: [:index | | segInfo occupiedSpace objectCount |
- do: [:index | | segInfo occupiedSpace |
segInfo := self segInfoAt: index.
occupiedSpace := 0.
+ objectCount := 0.
segmentManager
allEntitiesInSegment: segInfo
exceptTheLastBridgeDo: [:oop | | oopSize |
oopSize := self bytesInBody: oop.
(self isFreeOop: oop)
ifFalse: [
(self isMarked: oop)
+ ifTrue: [occupiedSpace := occupiedSpace + oopSize.
+ objectCount := objectCount + 1]]].
- ifTrue: [occupiedSpace := occupiedSpace + oopSize]]].
coInterpreter cr;
print: 'Segment ';
+ printNum: index; tab;
+ printNum: objectCount; print: ' objects -> ' ;
+ printNum: occupiedSpace; print: ' bytes -> ';
+ printNum: (occupiedSpace asFloat / (segInfo segSize)) * 100; print: ' % occupation';
- printNum: index;
- print: ' (starting at: ';
- printHex: segInfo segStart;
- print: ')';
- cr; flush.
-
- coInterpreter
- print: 'Currently occupied space: '; tab;
- printNum: occupiedSpace; tab;
- print: 'Resulting in an occupation percentage of: '; tab;
- printNum: (occupiedSpace asFloat / (segInfo segSize)) * 100;
flush.
].
coInterpreter cr; cr;
print: '----------------------------------------- '; cr;
print: '----------------------------------------- ';
cr.
!
Item was changed:
----- Method: SpurMemoryManager>>validObjectColors (in category 'debug support') -----
validObjectColors
| currentSweepingEntityT |
currentSweepingEntityT := gc sweepersCurrentSweepingEntity ifNil: [self firstObject].
self allOldSpaceEntitiesFrom: currentSweepingEntityT do: [:obj |
((self isMarked: obj) and: [(self isPointers: obj) and: [(self isContext: obj) not]])
ifTrue: [| slotCount |
slotCount := self numSlotsOf: obj.
0 to: slotCount - 1
do: [:index | | slot |
slot := self fetchPointer: index ofObject: obj.
((self isNonImmediate: slot) and: [(self isOldObject: slot) and: [(self isForwarded: slot) not]])
ifTrue: [(slot >= currentSweepingEntityT and: [(self isMarked: slot) not])
ifTrue: [
"for the 2 phase incremental gc. When we call this method while already having compacted some objects they are not marked anymore as we unmark them and do not sweep the segmentToFill"
+ (gc isInSegmentToFill: slot) not
- (compactor segmentToFill notNil and: [(self segmentManager is: slot inSegment: compactor segmentToFill) not])
ifTrue: [self halt.
coInterpreter longPrintOop: (self firstReferenceTo:(self firstReferenceTo: obj)).
self printReferencesTo: (self firstReferenceTo: obj).
self printReferencesTo: obj.
self printRelativePositionOf: obj.
self printRelativePositionOf: slot.
coInterpreter longPrintOop: obj.
coInterpreter longPrintOop: slot.
self cCode: 'raise(SIGINT)'.
^ false]]]]]].
^ true!
Item was removed:
- ----- Method: SpurPlanningCompactor>>segmentToFill (in category 'as yet unclassified') -----
- segmentToFill
-
- ^ nil!
Item was changed:
----- Method: SpurSegmentManager>>collapseSegmentsPostSwizzle (in category 'snapshot') -----
collapseSegmentsPostSwizzle
"The image has been loaded, old segments reconstructed, and the heap
swizzled into a single contiguous segment. Collapse the segments into one."
<inline: false>
canSwizzle := false.
self cCode: []
inSmalltalk:
[segments ifNil:
[self allocateOrExtendSegmentInfos]].
numSegments := 1.
(segments at: 0)
segStart: manager oldSpaceStart;
segSize: (totalHeapSizeIncludingBridges := manager endOfMemory - manager oldSpaceStart).
manager bootstrapping ifTrue:
["finally plant a bridge at the end of the coalesced segment and cut back the
manager's notion of the end of memory to immediately before the bridge."
self assert: manager endOfMemory = (segments at: 0) segLimit.
manager
initSegmentBridgeWithBytes: manager bridgeSize
at: manager endOfMemory - manager bridgeSize].
self assert: (manager isSegmentBridge: (self bridgeAt: 0)).
+ self assert: (manager numSlotsOfAny: (self bridgeAt: 0)) = 1!
- self assert: (manager numSlotsOfAny: (self bridgeAt: 0)) = 0!
Item was changed:
----- Method: SpurSegmentManager>>isValidSegmentBridge: (in category 'testing') -----
isValidSegmentBridge: objOop
"bridges bridge the gaps between segments. They are the last object in each segment."
^((manager addressCouldBeObj: objOop) or: [objOop = manager endOfMemory])
and: [(manager isSegmentBridge: objOop)
and: [(manager hasOverflowHeader: objOop)
+ or: [(manager numSlotsOfAny: objOop) < 3]]]!
- or: [(manager numSlotsOfAny: objOop) = 0]]]!
Item was changed:
----- Method: SpurSegmentManager>>shrinkObjectMemory: (in category 'growing/shrinking memory') -----
shrinkObjectMemory: delta
"Answer if any shrinkage was achieved."
<inline: false>
<var: #delta type: #usqInt>
| shrinkage emptySeg |
<var: #shrinkage type: #usqInt>
<var: #emptySeg type: #'SpurSegmentInfo *'>
manager checkFreeSpace: GCCheckFreeSpace.
shrinkage := delta.
[emptySeg := self findEmptySegNearestInSizeTo: shrinkage.
(emptySeg isNil
or: [emptySeg segSize > shrinkage]) ifTrue:
[manager checkFreeSpace: GCCheckFreeSpace.
^shrinkage < delta].
shrinkage := shrinkage - emptySeg segSize.
manager detachFreeObject: (manager objectStartingAt: emptySeg segStart).
manager coInterpreter cr;
print: 'remove segment starting: ';
printHex: emptySeg segStart;
print: ' to: ';
printHex: emptySeg segStart + emptySeg segSize; tab; flush.
+
-
- manager segmentToFill
- ifNil: [manager coInterpreter cr;
- print: 'segment to fill null '; tab; flush.]
- ifNotNil: [manager coInterpreter cr;
- print: 'segment to fill: ';
- printHex: manager segmentToFill segStart;
- print: ' to: ';
- printHex: manager segmentToFill segStart + manager segmentToFill segSize; tab; flush.].
self removeSegment: emptySeg] repeat!
Item was added:
+ ----- Method: SpurStopTheWorldGarbageCollector>>isInSegmentToFill: (in category 'as yet unclassified') -----
+ isInSegmentToFill: objOop
+
+ ^ false!
Item was changed:
----- Method: StackInterpreter class>>declareCVarsIn: (in category 'translation') -----
declareCVarsIn: aCCodeGenerator
| vmClass |
self class == thisContext methodClass ifFalse: [^self]. "Don't duplicate decls in subclasses"
vmClass := aCCodeGenerator vmClass. "Generate primitiveTable etc based on vmClass, not just StackInterpreter"
aCCodeGenerator
addHeaderFile: '<stdio.h> /* for printf */';
addHeaderFile: '<stdlib.h> /* for e.g. alloca */';
addHeaderFile: '<setjmp.h>';
addHeaderFile: '<wchar.h> /* for wint_t */';
addHeaderFile: '<signal.h>';
addHeaderFile: '"vmCallback.h"';
addHeaderFile: '"sqMemoryFence.h"';
addHeaderFile: '"sqImageFileAccess.h"';
addHeaderFile: '"sqSetjmpShim.h"';
addHeaderFile: '"dispdbg.h"'.
LowcodeVM ifTrue:
[aCCodeGenerator addHeaderFile: '"sqLowcodeFFI.h"'].
vmClass declareInterpreterVersionIn: aCCodeGenerator defaultName: 'Stack'.
aCCodeGenerator
var: #interpreterProxy type: #'struct VirtualMachine*'.
aCCodeGenerator
declareVar: #sendTrace type: 'volatile int';
declareVar: #byteCount type: #usqLong. "see dispdbg.h"
"These need to be pointers or unsigned."
self declareC: #(instructionPointer method newMethod)
as: #usqInt
in: aCCodeGenerator.
"These are all pointers; char * because Slang has no support for C pointer arithmetic."
self declareC: #(localIP localSP localFP stackPointer framePointer stackLimit breakSelector)
as: #'char *'
in: aCCodeGenerator.
aCCodeGenerator
var: #breakSelectorLength
declareC: 'sqInt breakSelectorLength = MinSmallInteger'.
self declareC: #(stackPage overflowedPage)
as: #'StackPage *'
in: aCCodeGenerator.
aCCodeGenerator
var: #transcript type: #'FILE *'.
aCCodeGenerator removeVariable: 'stackPages'. "this is an implicit receiver in the translated code."
"This defines bytecodeSetSelector as 0 if MULTIPLEBYTECODESETS
is not defined, for the benefit of the interpreter on slow machines."
aCCodeGenerator addConstantForBinding: (self bindingOf: #MULTIPLEBYTECODESETS).
MULTIPLEBYTECODESETS == false ifTrue:
[aCCodeGenerator
removeVariable: 'bytecodeSetSelector'].
BytecodeSetHasExtensions == false ifTrue:
[aCCodeGenerator
removeVariable: 'extA';
removeVariable: 'extB'].
aCCodeGenerator
var: #methodCache
declareC: 'sqIntptr_t methodCache[MethodCacheSize + 1 /* ', (MethodCacheSize + 1) printString, ' */]'.
NewspeakVM
ifTrue:
[aCCodeGenerator
var: #nsMethodCache
declareC: 'sqIntptr_t nsMethodCache[NSMethodCacheSize + 1 /* ', (NSMethodCacheSize + 1) printString, ' */]']
ifFalse:
[aCCodeGenerator
removeVariable: #nsMethodCache;
removeVariable: 'localAbsentReceiver';
removeVariable: 'localAbsentReceiverOrZero'].
AtCacheTotalSize isInteger ifTrue:
[aCCodeGenerator
var: #atCache
declareC: 'sqInt atCache[AtCacheTotalSize + 1 /* ', (AtCacheTotalSize + 1) printString, ' */]'].
aCCodeGenerator
var: #primitiveTable
declareC: 'void (*primitiveTable[MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */])(void) = ', vmClass primitiveTableString.
vmClass primitiveTable do:
[:symbolOrNot|
(symbolOrNot isSymbol
and: [symbolOrNot ~~ #primitiveFail]) ifTrue:
[(aCCodeGenerator methodNamed: symbolOrNot) ifNotNil:
[:tMethod| tMethod returnType: #void]]].
vmClass objectMemoryClass hasSpurMemoryManagerAPI
ifTrue:
[aCCodeGenerator
var: #primitiveAccessorDepthTable
type: 'signed char'
sizeString: 'MaxPrimitiveIndex + 2 /* ', (MaxPrimitiveIndex + 2) printString, ' */'
array: (vmClass primitiveAccessorDepthTableUsing: aCCodeGenerator).
aCCodeGenerator
removeConstant: #PrimNumberInstVarAt;
removeConstant: #PrimNumberPerform;
removeConstant: # PrimNumberPerformWithArgs;
removeConstant: #PrimNumberShallowCopy;
removeConstant: #PrimNumberSlotAt;
removeConstant: #PrimNumberFlushExternalPrimitives;
removeConstant: #PrimNumberUnloadModule]
ifFalse:
[aCCodeGenerator
removeVariable: #primitiveAccessorDepthTable;
removeConstant: #PrimNumberVMParameter].
aCCodeGenerator
var: #displayBits type: #'void *';
var: #primitiveCalloutPointer declareC: 'void *primitiveCalloutPointer = (void *)-1'.
#('primitiveDoMixedArithmetic' 'upscaleDisplayIfHighDPI' ) do:
[:var|
aCCodeGenerator
var: var
declareC: 'sqInt ', var, ' = -1'].
self declareC: #(displayWidth displayHeight displayDepth) as: #int in: aCCodeGenerator.
aCCodeGenerator
var: #primitiveFunctionPointer
declareC: 'void (*primitiveFunctionPointer)()';
var: 'pcPreviousToFunction'
declareC: 'sqInt (* const pcPreviousToFunction)(sqInt,sqInt) = ', (aCCodeGenerator cFunctionNameFor: PCPreviousToFunction);
var: #externalPrimitiveTable
declareC: 'void (*externalPrimitiveTable[MaxExternalPrimitiveTableSize + 1 /* ', (MaxExternalPrimitiveTableSize + 1) printString, ' */])(void)';
var: #interruptCheckChain
declareC: 'void (*interruptCheckChain)(void) = 0';
var: #showSurfaceFn
declareC: 'int (*showSurfaceFn)(sqIntptr_t, int, int, int, int)'.
self declareCAsUSqLong: #(nextPollUsecs nextWakeupUsecs
"these are high-frequency enough that they're overflowing quite quickly on modern hardware"
statProcessSwitch statIOProcessEvents statForceInterruptCheck
statCheckForEvents statStackOverflow statStackPageDivorce
statIdleUsecs)
in: aCCodeGenerator.
aCCodeGenerator var: #nextProfileTick type: #sqLong.
aCCodeGenerator var: #reenterInterpreter type: 'jmp_buf'.
LowcodeVM
ifTrue:
[aCCodeGenerator
var: #lowcodeCalloutState type: #'sqLowcodeCalloutState*'.
self declareC: #(nativeSP nativeStackPointer shadowCallStackPointer)
as: #'char *'
in: aCCodeGenerator]
ifFalse:
[#(lowcodeCalloutState nativeSP nativeStackPointer shadowCallStackPointer) do:
[:var| aCCodeGenerator removeVariable: var]].
(self instVarNames select: [:ivn| ivn beginsWith: 'longRunningPrimitive']) do:
[:lrpmVar|
aCCodeGenerator
var: lrpmVar
+ declareC: '#if LRPCheck\', ((lrpmVar endsWith: 'Usecs') ifTrue: [#usqLong] ifFalse: [#sqInt]), ' ', lrpmVar, '\#endif'].
+
+ SpurMemoryManager wantsIncrementalGC
+ ifTrue: [
+ aCCodeGenerator
+ recursivelyResolvePolymorpicReceiver: 'objectMemory' toVariants: {SpurIncrementalGarbageCollector. SpurStopTheWorldGarbageCollector} in: self default: SpurIncrementalGarbageCollector forMethodList: #(mapInterpreterOops mapStackPages mapVMRegisters mapProfileState)
+ ]!
- declareC: '#if LRPCheck\', ((lrpmVar endsWith: 'Usecs') ifTrue: [#usqLong] ifFalse: [#sqInt]), ' ', lrpmVar, '\#endif']!
Item was changed:
----- Method: StackInterpreter>>mapInterpreterOops (in category 'object memory support') -----
mapInterpreterOops
"Map all oops in the interpreter's state to their new values
during garbage collection or a become: operation."
"Assume: All traced variables contain valid oops."
- <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector>
<inline: false>
self mapStackPages.
self mapMachineCode: self getGCMode.
self mapTraceLogs.
self mapVMRegisters.
self mapProfileState.
(tempOop ~= 0
and: [objectMemory shouldRemapOop: tempOop]) ifTrue:
[tempOop := objectMemory remapObj: tempOop].
(tempOop2 ~= 0
and: [objectMemory shouldRemapOop: tempOop2]) ifTrue:
[tempOop2 := objectMemory remapObj: tempOop2].
objectMemory hasSpurMemoryManagerAPI ifFalse:
[self getClassTagOfLinkedList]!
Item was changed:
----- Method: StackInterpreter>>mapProfileState (in category 'object memory support') -----
mapProfileState
+
- <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector>
(objectMemory shouldRemapObj: profileProcess) ifTrue:
[profileProcess := objectMemory remapObj: profileProcess].
(objectMemory shouldRemapObj: profileMethod) ifTrue:
[profileMethod := objectMemory remapObj: profileMethod].
(objectMemory shouldRemapObj: profileSemaphore) ifTrue:
[profileSemaphore := objectMemory remapObj: profileSemaphore].
self cppIf: #LRPCheck
ifTrue:
["The longRunningPrimitiveCheckMethod (LRPCM) is sampled in an interrupt. Be very careful with it.
If longRunningPrimitiveCheckSequenceNumber (LRPCSN) = statCheckForEvents then LRPCM has
been recenty sampled and could be mapped or not, but it must be newMethod and we can simply
copy newMethod. If LRPCSN ~= statCheckForEvents then LRPCM must be some extant object and
needs to be remapped."
self sqLowLevelMFence.
longRunningPrimitiveCheckMethod ifNotNil:
[longRunningPrimitiveCheckSequenceNumber = statCheckForEvents
ifTrue: [longRunningPrimitiveCheckMethod := newMethod]
ifFalse:
[(objectMemory shouldRemapObj: longRunningPrimitiveCheckMethod) ifTrue:
[longRunningPrimitiveCheckMethod := objectMemory remapObj: longRunningPrimitiveCheckMethod]].
self sqLowLevelMFence].
longRunningPrimitiveCheckSemaphore ifNotNil:
[(objectMemory shouldRemapObj: longRunningPrimitiveCheckSemaphore) ifTrue:
[longRunningPrimitiveCheckSemaphore := objectMemory remapObj: longRunningPrimitiveCheckSemaphore]]]!
Item was changed:
----- Method: StackInterpreter>>mapStackPages (in category 'object memory support') -----
mapStackPages
<inline: #never>
<var: #thePage type: #'StackPage *'>
<var: #theSP type: #'char *'>
<var: #theFP type: #'char *'>
<var: #callerFP type: #'char *'>
<var: #theIPPtr type: #'char *'>
- <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector>
| numLivePages |
numLivePages := 0.
0 to: numStackPages - 1 do:
[:i| | thePage theSP theFP callerFP theIPPtr theIP oop |
thePage := stackPages stackPageAt: i.
thePage isFree ifFalse:
[self assert: (self ifCurrentStackPageHasValidHeadPointers: thePage).
numLivePages := numLivePages + 1.
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 + objectMemory wordSize].
[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 + objectMemory wordSize].
(self frameHasContext: theFP) ifTrue:
[(objectMemory shouldRemapObj: (self frameContext: theFP)) ifTrue:
[stackPages
longAt: theFP + FoxThisContext
put: (objectMemory remapObj: (self frameContext: theFP))].
"With SqueakV3 objectMemory or SpurPlanningCompactor can't assert since object body is yet to move."
(objectMemory hasSpurMemoryManagerAPI
and: [objectMemory slidingCompactionInProgress not]) ifTrue:
[self assert: ((self isMarriedOrWidowedContext: (self frameContext: theFP))
and: [(self frameOfMarriedContext: (self frameContext: theFP)) = 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) + objectMemory wordSize.
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 + objectMemory wordSize]]].
stackPages recordLivePagesOnMapping: numLivePages!
Item was changed:
----- Method: StackInterpreter>>mapVMRegisters (in category 'object memory support') -----
mapVMRegisters
"Map the oops in the interpreter's vm ``registers'' to their new values
during garbage collection or a become: operation."
"Assume: All traced variables contain valid oops.
N.B. Don't trace messageSelector and lkupClass; these are ephemeral, live
only during message lookup and because createActualMessageTo will not
cause a GC these cannot change during message lookup."
- <declareTypeForStaticPolymorphism: #SpurStopTheWorldGarbageCollector>
(objectMemory shouldRemapObj: method) ifTrue:
[instructionPointer := instructionPointer - method. "*rel to method"
method := objectMemory remapObj: method.
instructionPointer := instructionPointer + method]. "*rel to method"
(objectMemory shouldRemapOop: newMethod) ifTrue: "maybe oop due to object-as-method"
[newMethod := objectMemory remapObj: newMethod]!
Item was changed:
+ ----- Method: TMethod>>asPolymorphicBaseFor:toResolve:default: (in category 'static polymorphism') -----
- ----- Method: TMethod>>asPolymorphicBaseFor:toResolve:default: (in category 'as yet unclassified') -----
asPolymorphicBaseFor: aClassCollection toResolve: aSymbol default: defaultClass
| method |
self assert: (aClassCollection includes: defaultClass).
method := PolymorphicBaseTMethod new.
method
copyFrom: self;
classes: aClassCollection;
default: defaultClass;
receiverToResolve: aSymbol.
^ method!
Item was changed:
+ ----- Method: TMethod>>asPolymorphicFor:resolveTo: (in category 'static polymorphism') -----
- ----- Method: TMethod>>asPolymorphicFor:resolveTo: (in category 'as yet unclassified') -----
asPolymorphicFor: aSymbol resolveTo: aClass
| method |
method := PolymorphicTMethod new.
method
copyFrom: self;
receiverToResolve: aSymbol;
receiverClass: aClass;
+ oldSelector: self selector;
selector: (self polymorphicSelectorForClass: aClass).
^ method!
Item was added:
+ ----- Method: TMethod>>fasterDeepCopy (in category 'static polymorphism') -----
+ fasterDeepCopy
+
+ "copy of veryDeepCopy without the handling of dependents (I assume that is not
+ needed for TMethods + it makes a noticable performance difference)"
+ | copier new |
+ copier := DeepCopier new: self initialDeepCopierSize.
+ new := self veryDeepCopyWith: copier.
+ copier mapUniClasses.
+ copier references associationsDo: [:assoc |
+ assoc value veryDeepFixupWith: copier].
+ ^ new!
Item was changed:
----- Method: TMethod>>inlineFunctionCall:in: (in category 'inlining') -----
inlineFunctionCall: aSendNode in: aCodeGen
"Answer the body of the called function, substituting the actual
parameters for the formal argument variables in the method body.
Assume caller has established that:
1. the method arguments are all substitutable nodes, and
2. the method to be inlined contains no additional embedded returns."
| sel meth doNotRename argsForInlining substitutionDict |
aCodeGen maybeBreakForInlineOf: aSendNode in: self.
sel := aSendNode selector.
meth := (aCodeGen methodNamed: sel) copy.
meth ifNil:
[^self inlineBuiltin: aSendNode in: aCodeGen].
doNotRename := Set withAll: args.
argsForInlining := aSendNode argumentsForInliningCodeGenerator: aCodeGen.
[meth args with: argsForInlining do:
[ :argName :exprNode |
exprNode isLeaf ifTrue:
[doNotRename add: argName]]]
on: Error
do: [:ex | ex messageText = 'Other collection must be the same size'
ifTrue: [ | errorMessage |
errorMessage := 'In ' , self definingClass name, '>>' , self selector.
errorMessage := errorMessage , ' for method ' , meth definingClass name, '>>' , meth selector.
errorMessage := errorMessage , ' following args where expected {' , (argsForInlining joinSeparatedBy: ', ') , '}'.
errorMessage := errorMessage , ' but got {' , (meth args joinSeparatedBy: ', ') , '}'.
"the errorMessage is probably extremenly long and not that easy to read in the header of the Debugger
window. => print it on the transcript for better readability (as multiline strings in window titles seem
not to be supported :( "
Transcript showln: errorMessage.
+ "Note: I (Tom Braun) found this exception to be triggered in two cases:
+ - I made an error in the code like forgetting a point and the next statement was interpreted as the receiver which is of course nonsene
+ - I introduced a new variable that should be ignored during code generation (like manager in all of the GC classes)
+
+ Please take a look at:
+ Browser fullOnClass: self definingClass selector: self unmodifiedSelector
+ and look for
+ aSendNode asString "
+
self error: errorMessage]
ifFalse: [ex signal]].
(meth statements size = 2
and: [meth statements first isSend
and: [meth statements first selector == #flag:]]) ifTrue:
[meth statements removeFirst].
meth renameVarsForInliningInto: self except: doNotRename in: aCodeGen.
meth renameLabelsForInliningInto: self.
self addVarsDeclarationsAndLabelsOf: meth except: doNotRename.
substitutionDict := Dictionary new: meth args size * 2.
meth args with: argsForInlining do:
[ :argName :exprNode |
(exprNode isVariable and: [exprNode name = argName]) ifFalse:
[substitutionDict at: argName put: exprNode].
(doNotRename includes: argName) ifFalse:
[locals remove: argName]].
meth parseTree bindVariablesIn: substitutionDict.
^meth parseTree endsWithReturn
ifTrue: [meth parseTree copyWithoutReturn]
ifFalse: [meth parseTree]!
Item was changed:
----- Method: TMethod>>inlineableSend:in: (in category 'inlining') -----
inlineableSend: aNode in: aCodeGen
"Answer if the given send node is a call to a method that can be inlined."
| m |
aCodeGen maybeBreakForTestToInline: aNode in: self.
aNode isSend ifFalse: [^false].
m := aCodeGen methodNamed: aNode selector. "nil if builtin or external function"
+
^m ~= nil
and: [m ~~ self
+ and: [m unmodifiedSelector ~= self unmodifiedSelector
and: [m mayBeInlined
and: [(m isComplete and: [aCodeGen mayInline: m selector])
+ or: [m checkForRequiredInlinability]]]]]!
- or: [m checkForRequiredInlinability]]]]!
Item was changed:
+ ----- Method: TMethod>>polymorphicSelectorForClass: (in category 'static polymorphism') -----
- ----- Method: TMethod>>polymorphicSelectorForClass: (in category 'as yet unclassified') -----
polymorphicSelectorForClass: aClass
^ ((aClass name select: [:ea| ea isUppercase]), '_', self selector) asSymbol!
Item was added:
+ ----- Method: TMethod>>unmodifiedSelector (in category 'static polymorphism') -----
+ unmodifiedSelector
+ "I am not sure if any of the other selector accesses are overloaded or used otherwise in the system
+ -> I write this to be extra sure it is only used where I want it to be used"
+
+ ^ self selector!
Item was changed:
----- Method: VMMaker class>>generateSqueakSpurIncrementalStack64VM (in category 'configurations') -----
generateSqueakSpurIncrementalStack64VM
"No primitives since we can use those from the Cog VM"
^VMMaker
generate: StackInterpreter
with: #(ObjectMemory Spur64BitMemoryManager
FailImbalancedPrimitives false
MULTIPLEBYTECODESETS true
TempVectReadBarrier true
+ gcClass SpurIncrementalGarbageCollector
bytecodeTableInitializer initializeBytecodeTableForSqueakV3PlusClosuresSistaV1Hybrid)
to: self sourceTree, '/src/spur64.stack'
platformDir: self sourceTree, '/platforms'
including: #()!
More information about the Vm-dev
mailing list