--- a/ObjectMemory.st Thu Apr 11 15:24:25 2019 +0200
+++ b/ObjectMemory.st Thu Apr 11 16:01:45 2019 +0200
@@ -17,23 +17,21 @@
Object subclass:#ObjectMemory
instanceVariableNames:''
- classVariableNames:'InternalErrorHandler UserInterruptHandler TimerInterruptHandler
- SpyInterruptHandler StepInterruptHandler
- ExceptionInterruptHandler ErrorInterruptHandler
- MemoryInterruptHandler SignalInterruptHandler
- ChildSignalInterruptHandler DisposeInterruptHandler
- RecursionInterruptHandler IOInterruptHandler
- CustomInterruptHandler RegisteredErrorInterruptHandlers
- InterruptLatencyMonitor AllocationFailureSignal
- MallocFailureSignal LowSpaceSemaphore IncrementalGCLimit
- FreeSpaceGCLimit FreeSpaceGCAmount BackgroundCollectProcess
- BackgroundFinalizationProcess FinalizationSemaphore Dependents
- ImageName ImageSaveTime ChangeFileName MaxInterruptLatency
- InterruptLatencyGoal VMSelectors DynamicCodeGCTrigger
- DynamicCodeLimit JustInTimeCompilationEnabled
- JavaJustInTimeCompilationEnabled JavaNativeCodeOptimization
- BackgroundCollectMaximumInterval SavedGarbageCollectorSettings
- FinalizerAccessLock'
+ classVariableNames:'AllocationFailureSignal BackgroundCollectMaximumInterval
+ BackgroundCollectProcess BackgroundFinalizationProcess
+ ChangeFileName ChildSignalInterruptHandler CustomInterruptHandler
+ Dependents DisposeInterruptHandler DynamicCodeGCTrigger
+ DynamicCodeLimit ErrorInterruptHandler ExceptionInterruptHandler
+ FinalizationSemaphore FinalizerAccessLock FreeSpaceGCAmount
+ FreeSpaceGCLimit IOInterruptHandler ImageName ImageSaveTime
+ IncrementalGCLimit InternalErrorHandler InterruptLatencyGoal
+ InterruptLatencyMonitor JavaJustInTimeCompilationEnabled
+ JavaNativeCodeOptimization JustInTimeCompilationEnabled
+ LowSpaceSemaphore MallocFailureSignal MaxInterruptLatency
+ MemoryInterruptHandler RecursionInterruptHandler
+ RegisteredErrorInterruptHandlers SavedGarbageCollectorSettings
+ SignalInterruptHandler SpyInterruptHandler StepInterruptHandler
+ TimerInterruptHandler UserInterruptHandler VMSelectors'
poolDictionaries:''
category:'System-Support'
!
@@ -1436,11 +1434,8 @@
!
displayRefChainToAny:aCollection limitNumberOfSearchedReferences:limitOrNil
- |levels objects done showMore stop userStop chain
- top progress lbl h nDone nAll panel listV
- moreButton owners objectArray numObjects numObjectsDone
- found moreChainsOnThisLevel temporaryRemoved chains
- anyShown anyShownInAnyLevel list tLevels firstRound delay|
+ |top lbl h progress listV panel stop userStop moreButton showMore
+ levels objects done anyShown anyShownInAnyLevel firstRound|
top := StandardSystemView new.
top extent:350@250.
@@ -1497,277 +1492,278 @@
levels := OrderedCollection new.
objects := WeakIdentitySet withAll:aCollection.
- done := (objects includesIdentical:Smalltalk).
+ done := objects includesIdentical:Smalltalk.
stop := userStop := false.
anyShown := anyShownInAnyLevel := false.
+ firstRound := true.
"/ consider this a kludge:
"/ the processes are not held in any global; they are (currently)
"/ only known to the VM.
"/ In order to find a global ref, temporarily create one here.
"/ These are released later.
-
Smalltalk at:#'__VMProcesses__' put:(self processesKnownInVM).
- firstRound := true.
-
- [done] whileFalse:[
- anyShown := false.
-
- progress percentage:0.
- firstRound ifTrue:[
- firstRound := false.
- ] ifFalse:[
- lbl label:'compressing garbage ...'.
- self garbageCollect.
- ].
-
- lbl label:('searching level '
- , levels size printString
- , ' (' , objects size printString , ' refs) ...').
- nAll := objects size.
- nDone := 0.
-
- objectArray := objects asArray.
-
- owners := "Weak"IdentitySet new.
-
- numObjectsDone := 0.
- found := false.
-
- AbortOperationRequest catch:[
- self allObjectsIncludingContextsDo:[:o |
- |inPrevLevel isOwner|
-
- stop ifTrue:[AbortOperationRequest raise].
- stop ifFalse:[
- isOwner := false.
- (o referencesAny:objectArray) ifTrue:[
- o isBehavior ifTrue:[
- o == Smalltalk ifTrue:[
- found := true.
+ [ "ensure..."
+ |chain nDone nAll
+ owners objectArray numObjects numObjectsDone
+ found moreChainsOnThisLevel temporaryRemoved chains
+ list tLevels delay|
+
+ [done] whileFalse:[
+ anyShown := false.
+
+ progress percentage:0.
+ firstRound ifTrue:[
+ firstRound := false.
+ ] ifFalse:[
+ lbl label:'compressing garbage ...'.
+ self garbageCollect.
+ ].
+
+ lbl label:('searching level '
+ , levels size printString
+ , ' (' , objects size printString , ' refs) ...').
+ nAll := objects size.
+ nDone := 0.
+
+ objectArray := objects asArray.
+
+ owners := "Weak"IdentitySet new.
+
+ numObjectsDone := 0.
+ found := false.
+
+ AbortOperationRequest catch:[
+ self allObjectsIncludingContextsDo:[:o |
+ |inPrevLevel isOwner|
+
+ stop ifTrue:[
+ AbortOperationRequest raise
+ ] ifFalse:[
+ isOwner := false.
+ (o referencesAny:objectArray) ifTrue:[
+ o isBehavior ifTrue:[
+ o == Smalltalk ifTrue:[
+ found := true.
+ ] ifFalse:[
+ "/ only add it if it has classInstVars
+ o instSize ~~ Class instSize ifTrue:[
+ isOwner := true.
+ ]
+ ]
] ifFalse:[
- "/ only add it if it has classInstVars
- o instSize ~~ Class instSize ifTrue:[
+ o class ~~ WeakArray ifTrue:[
isOwner := true.
]
- ]
- ] ifFalse:[
- o class ~~ WeakArray ifTrue:[
- isOwner := true.
+ ].
+ ].
+
+ isOwner ifTrue:[
+ (objects includesIdentical:o) ifFalse:[
+ inPrevLevel := false.
+ levels do:[:lColl |
+ lColl == o ifTrue:[
+ inPrevLevel := true
+ ] ifFalse:[
+ (lColl includesIdentical:o) ifTrue:[inPrevLevel := true].
+ ]
+ ].
+ inPrevLevel ifFalse:[
+ owners add:o.
+ (limitOrNil notNil and:[owners size >= limitOrNil]) ifTrue:[
+ AbortOperationRequest raise
+ ].
+ ]
]
].
- ].
-
- isOwner ifTrue:[
- (objects includesIdentical:o) ifFalse:[
- inPrevLevel := false.
- levels do:[:lColl |
- lColl == o ifTrue:[
- inPrevLevel := true
- ] ifFalse:[
- (lColl includesIdentical:o) ifTrue:[inPrevLevel := true].
- ]
- ].
- inPrevLevel ifFalse:[
- owners add:o.
- (limitOrNil notNil and:[owners size >= limitOrNil]) ifTrue:[
- AbortOperationRequest raise
- ].
+
+ numObjectsDone := numObjectsDone + 1.
+ numObjects notNil ifTrue:[
+ numObjectsDone \\ 1000 == 0 ifTrue:[
+ progress percentage:(numObjectsDone / numObjects * 100).
+ Processor yield.
]
]
- ].
-
- numObjectsDone := numObjectsDone + 1.
- numObjects notNil ifTrue:[
- numObjectsDone \\ 1000 == 0 ifTrue:[
- progress percentage:(numObjectsDone / numObjects * 100).
- Processor yield.
- ]
]
- ]
+ ].
+ ].
+ progress percentage:100.
+
+ numObjects isNil ifTrue:[
+ numObjects := numObjectsDone.
].
- ].
- progress percentage:100.
-
- numObjects isNil ifTrue:[
- numObjects := numObjectsDone.
- ].
-
- owners remove:aCollection ifAbsent:nil.
- owners remove:thisContext ifAbsent:nil.
- owners remove:objectArray ifAbsent:nil.
- owners remove:objects keyArray ifAbsent:nil.
- owners remove:owners keyArray ifAbsent:nil.
-
-"/ 'done with level: ' print. levels size print. ' found ' print. owners size print. ' refs' printCR.
-
- owners isEmpty ifTrue:[
- found ifFalse:[
+
+ owners remove:aCollection ifAbsent:nil.
+ owners remove:thisContext ifAbsent:nil.
+ owners remove:objectArray ifAbsent:nil.
+ owners remove:objects keyArray ifAbsent:nil.
+ owners remove:owners keyArray ifAbsent:nil.
+
+ "/ 'done with level: ' print. levels size print. ' found ' print. owners size print. ' refs' printCR.
+
+ (found not and:[owners isEmpty]) ifTrue:[
stop := true.
- ]
- ].
-
- stop ifFalse:[
- done := found or:[(owners includesIdentical:Smalltalk)].
- done ifTrue:[
- moreChainsOnThisLevel := true.
- temporaryRemoved := IdentitySet new.
-
- levels size ~~ 0 ifTrue:[
- "/ show what we found so far.
- levels last add:Smalltalk.
- levels reverse.
- ].
-
- chains := OrderedCollection new.
-
- tLevels := levels collect:[:lColl | lColl copy].
-
- lbl label:('building refchains ...').
-
- nAll := aCollection size.
- nDone := 0.
- aCollection do:[:anObject | |theseChains|
- stop ifFalse:[
- theseChains := self
- refChainsFrom:Smalltalk
- to:anObject
- inRefSets:tLevels
- startingAt:1.
-
- theseChains size ~~ 0 ifTrue:[
- chains addAll:theseChains
+ ].
+
+ stop ifFalse:[
+ done := found or:[(owners includesIdentical:Smalltalk)].
+ done ifTrue:[
+ moreChainsOnThisLevel := true.
+ temporaryRemoved := IdentitySet new.
+
+ levels size ~~ 0 ifTrue:[
+ "/ show what we found so far.
+ levels last add:Smalltalk.
+ levels reverse.
+ ].
+
+ chains := OrderedCollection new.
+
+ tLevels := levels collect:[:lColl | lColl copy].
+
+ lbl label:('building refchains ...').
+
+ nAll := aCollection size.
+ nDone := 0.
+ aCollection do:[:anObject | |theseChains|
+ stop ifFalse:[
+ theseChains := self
+ refChainsFrom:Smalltalk
+ to:anObject
+ inRefSets:tLevels
+ startingAt:1.
+
+ theseChains notEmpty ifTrue:[
+ chains addAll:theseChains
+ ].
+ nDone := nDone + 1.
+ progress percentage:(nDone / nAll * 100).
+ ]
+ ].
+
+ tLevels := nil.
+
+ levels notEmpty ifTrue:[
+ levels reverse.
+ levels last remove:Smalltalk.
+ ].
+
+ [stop not
+ and:[chains notEmpty]] whileTrue:[
+ chain := chains first.
+ chains removeFirst.
+
+ lbl label:('Found a reference chain.').
+ progress beInvisible.
+
+ chain addFirst:Smalltalk.
+ list := OrderedCollection newWithSize:chain size.
+ 1 to:chain size-1 do:[:i |
+ list
+ at:i
+ put:(self refNameFor:(chain at:i+1) in:(chain at:i))
].
- nDone := nDone + 1.
- progress percentage:(nDone / nAll * 100).
+ list at:list size put:(chain last class nameWithArticle).
+
+ "/ hide the VMProcesses stuff from the user ...
+ (list at:1) string = 'Smalltalk:__VMProcesses__' ifTrue:[
+ list at:1 put:'__VMProcesses__ (a hidden VM reference)'.
+ list removeIndex:2.
+ chain at:1 put:nil.
+ chain removeIndex:2.
+ ].
+
+ listV list:list.
+
+ listV beVisible.
+ listV
+ doubleClickAction:[:idx |
+ |o key idxOfColon mayBeClassName mayBeClassVarName cls|
+
+ (o := chain at:idx) notNil ifTrue:[
+ key := (list at:idx) string.
+ (key includes:$:) ifTrue:[
+ idxOfColon := key lastIndexOf:$:.
+ mayBeClassName := key copyTo:idxOfColon-1.
+ mayBeClassVarName := key copyFrom:idxOfColon+1.
+ (cls := Smalltalk classNamed:mayBeClassName) notNil ifTrue:[
+ o := cls
+ ].
+ ].
+ o inspect.
+ ]
+ ].
+ moreButton beVisible.
+ anyShown := anyShownInAnyLevel := true.
+ showMore := false.
+
+ "/ kludge - wait for some user action
+
+ delay := Delay forSeconds:0.1.
+ [showMore or:[stop or:[top realized not]]] whileFalse:[
+ delay wait.
+ ].
+
+ chain := nil.
+
+ top realized ifFalse:[
+ stop := true
+ ] ifTrue:[
+ listV doubleClickAction:nil.
+ showMore ifFalse:[
+ stop := true.
+ ].
+ ].
+ done := false.
+
+ stop ifFalse:[
+ progress beVisible.
+ listV beInvisible.
+ moreButton beInvisible.
+
+ chain := nil.
+ ]
+ ].
+ levels notEmpty ifTrue:[
+ levels last addAll:temporaryRemoved.
]
].
-
- tLevels := nil.
-
- levels size ~~ 0 ifTrue:[
- levels reverse.
- levels last remove:Smalltalk.
- ].
-
- [stop not
- and:[chains size ~~ 0]] whileTrue:[
- chain := chains first.
- chains removeFirst.
-
- lbl label:('Found a reference chain.').
- progress beInvisible.
-
- chain addFirst:Smalltalk.
- list := OrderedCollection newWithSize:chain size.
- 1 to:chain size-1 do:[:i |
- list
- at:i
- put:(self refNameFor:(chain at:i+1) in:(chain at:i))
- ].
- list at:list size put:(chain last class nameWithArticle).
-
- "/ hide the VMProcesses stuff from the user ...
- (list at:1) string = 'Smalltalk:__VMProcesses__' ifTrue:[
- list at:1 put:'__VMProcesses__ (a hidden VM reference)'.
- list removeIndex:2.
- chain at:1 put:nil.
- chain removeIndex:2.
- ].
-
- listV list:list.
-
- listV beVisible.
- listV
- doubleClickAction:[:idx |
- |o key idxOfColon mayBeClassName mayBeClassVarName cls|
-
- (o := chain at:idx) notNil ifTrue:[
- key := (list at:idx) string.
- (key includes:$:) ifTrue:[
- idxOfColon := key lastIndexOf:$:.
- mayBeClassName := key copyTo:idxOfColon-1.
- mayBeClassVarName := key copyFrom:idxOfColon+1.
- (cls := Smalltalk classNamed:mayBeClassName) notNil ifTrue:[
- o := cls
- ].
- ].
- o inspect.
- ]
- ].
- moreButton beVisible.
- anyShown := anyShownInAnyLevel := true.
- showMore := false.
-
- "/ kludge - wait for some user action
-
- delay := Delay forSeconds:0.1.
- [showMore or:[stop or:[top realized not]]] whileFalse:[
- delay wait.
- ].
-
- chain := nil.
-
- top realized ifFalse:[
- stop := true
- ] ifTrue:[
- listV doubleClickAction:nil.
- showMore ifFalse:[
- stop := true.
- ].
- ].
- done := false.
-
- stop ifFalse:[
- progress beVisible.
- listV beInvisible.
- moreButton beInvisible.
-
- chain := nil.
- ]
- ].
- levels size ~~ 0 ifTrue:[
- levels last addAll:temporaryRemoved.
- ]
+ ].
+
+ owners remove:Smalltalk ifAbsent:nil.
+ owners remove:(owners keyArray) ifAbsent:nil.
+ owners remove:objectArray ifAbsent:nil.
+ levels do:[:lColl |
+ owners remove:lColl ifAbsent:nil
+ ].
+
+ levels add:owners.
+
+ objects := owners.
+
+ objects isEmpty ifTrue:[
+ stop := true
].
- ].
-
- owners remove:Smalltalk ifAbsent:nil.
- owners remove:(owners keyArray) ifAbsent:nil.
- owners remove:objectArray ifAbsent:nil.
- levels do:[:lColl |
- owners remove:lColl ifAbsent:nil
- ].
-
- levels add:owners.
-
- objects := owners.
-
- objects size == 0 ifTrue:[
- stop := true
+
+ stop ifTrue:[
+ top destroy.
+ anyShown ifFalse:[
+ userStop ifFalse:[
+ self information:(anyShownInAnyLevel ifTrue:['no more references'] ifFalse:['no references']).
+ ]
+ ].
+ ^ self.
+ ].
+
].
-
- stop ifTrue:[
- Smalltalk at:#'__VMProcesses__' put:nil.
- top destroy.
- anyShown ifFalse:[
- userStop ifFalse:[
- self information:(anyShownInAnyLevel ifTrue:['no more references'] ifFalse:['no references']).
- ]
- ].
- ^ self.
- ].
-
+ ] ensure:[
+ Smalltalk at:#'__VMProcesses__' put:nil.
].
- anyShown ifTrue:[
- userStop ifFalse:[
- self information:'no more references'.
- ]
+ (anyShownInAnyLevel and:[userStop not]) ifTrue:[
+ self information:'no more references'.
].
- Smalltalk at:#'__VMProcesses__' put:nil.
- ^ self
"
self displayRefChainTo:Point new
@@ -1815,6 +1811,7 @@
"Modified: / 10-07-1998 / 17:22:06 / cg"
"Modified: / 21-02-2017 / 09:49:40 / stefan"
"Modified: / 01-03-2019 / 16:04:48 / Claus Gittinger"
+ "Modified: / 11-04-2019 / 15:56:16 / Stefan Vogel"
!
dumpObject:someObject
@@ -1917,30 +1914,30 @@
|chain|
index > levels size ifTrue:[
- (start referencesObject:anObject) ifTrue:[
- ^ OrderedCollection with:anObject. "/ (self refNameFor:anObject in:start)
- ].
- ^ nil.
+ (start referencesObject:anObject) ifTrue:[
+ ^ OrderedCollection with:anObject. "/ (self refNameFor:anObject in:start)
+ ].
+ ^ #().
].
(levels at:index) do:[:el |
el ~~ start ifTrue:[
- (start referencesObject:el) ifTrue:[
- chain := self
- refChainFrom:el
- to:anObject
- inRefSets:levels
- startingAt:(index+1).
-
- chain notNil ifTrue:[
- (levels at:index) safeRemove:el.
- chain addFirst:el. "/ (self refNameFor:el in:start).
- ^ chain.
- ]
- ].
+ (start referencesObject:el) ifTrue:[
+ chain := self
+ refChainFrom:el
+ to:anObject
+ inRefSets:levels
+ startingAt:(index+1).
+
+ chain notEmpty ifTrue:[
+ (levels at:index) safeRemove:el.
+ chain addFirst:el. "/ (self refNameFor:el in:start).
+ ^ chain.
+ ]
+ ].
].
].
- ^ nil
+ ^ #()
"
@@ -1960,14 +1957,15 @@
a2 := Array with:a1.
a3 := Array with:a2.
a4 := Array with:a3.
- levels := Array with:(Array with:a3)
- with:(Array with:a2)
- with:(Array with:a1).
+ levels := Array with:(Set with:a3)
+ with:(Set with:a2)
+ with:(Set with:a1).
self refChainFrom:a4 to:o inRefSets:levels startingAt:1.
"
- "Modified: / 3.2.1998 / 02:38:27 / cg"
+ "Modified: / 03-02-1998 / 02:38:27 / cg"
+ "Modified (comment): / 11-04-2019 / 15:53:51 / Stefan Vogel"
!
refChainsFrom:start to:anObject inRefSets:levels startingAt:index
@@ -1991,7 +1989,7 @@
inRefSets:levels
startingAt:(index+1).
- chain size ~~ 0 ifTrue:[
+ chain notEmpty ifTrue:[
(levels at:index) safeRemove:el.
c := chain copy.
@@ -2006,6 +2004,7 @@
"Created: / 02-02-1998 / 19:09:22 / cg"
"Modified: / 03-02-1998 / 02:38:17 / cg"
"Modified: / 01-03-2019 / 16:04:15 / Claus Gittinger"
+ "Modified: / 11-04-2019 / 15:44:01 / Stefan Vogel"
!
refNameFor:anObject in:referent