Leon Matthes uploaded a new version of CogTools to project VM Maker: http://source.squeak.org/VMMaker/CogTools.threaded-LM.97.mcz
==================== Summary ====================
Name: CogTools.threaded-LM.97 Author: LM Time: 6 December 2023, 5:40:47.431589 pm UUID: f3c69d53-4c8d-441f-989a-b691bc5b7ae7 Ancestors: CogTools.threaded-LM.96
Add a rudamentary thread inspector.
=============== Diff against CogTools.threaded-LM.96 ===============
Item was changed: SystemOrganization addCategory: #'CogTools-VMProfiler'! + SystemOrganization addCategory: #'CogTools-Listener'! + SystemOrganization addCategory: #'CogTools-ThreadInspector'!
Item was removed: - ----- Method: AxesMorph>>drawGridOn: (in category 'drawing') ----- - drawGridOn: aCanvas - | gridColor right bottom width height lighter darker baseColor | - baseColor := self baseColor. - lighter := baseColor twiceLighter. - darker := baseColor twiceDarker. - gridColor := (lighter diff: baseColor) - > (darker diff: baseColor) ifTrue: [lighter] ifFalse: [darker]. - "" - right := self bounds width - margin. - width := self bounds width - (margin * 2). - bottom := self bounds height - margin. - height := self bounds height - (margin * 2). - (margin to: right by: width / 10) do: - [:x | | xRounded | - xRounded := x rounded. - aCanvas - line: xRounded @ margin - to: xRounded @ bottom - color: gridColor]. - (margin to: bottom by: height / 10) do: - [:y | | yRounded | - yRounded := y rounded. - aCanvas - line: margin @ yRounded - to: right @ yRounded - color: gridColor]!
Item was added: + ----- Method: AxesMorph>>gridClass (in category 'accessing') ----- + gridClass + + ^ PlotMorphGrid!
Item was changed: ----- Method: AxesMorph>>initialize (in category 'initialization') ----- initialize
super initialize.
self color: Color gray. + grid := self gridClass on: self. - grid := PlotMorphGrid on: self.
xAxisFormatter := [:x | x printString]. yAxisFormatter := [:y | y printString]. self initializeCotas. margin := 15 max: (title height + 2). form := nil. self extent: 1@1.!
Item was added: + ----- Method: PositionableStream>>nextChunkNoTag (in category '*CogTools-Listener') ----- + nextChunkNoTag + "Answer the contents of the receiver, up to the next terminator character. + Doubled terminators indicate an embedded terminator character. + Unlike nextChunk, do not look for ]lang[ tags." + | skippingSeparators terminator out ch | + terminator := $!!. + skippingSeparators := true. "inline skipSeparators since restoreStateOf:with: is not reliable" + out := WriteStream on: (String new: 1000). + [(ch := self next) == nil] whileFalse: + [ch == terminator ifTrue: + [self peek == terminator + ifTrue:"skip doubled terminator" + [self next] + ifFalse: + [^out contents "terminator is not doubled; we're done!!"]]. + (skippingSeparators and: [ch isSeparator]) ifFalse: + [out nextPut: ch. + skippingSeparators := false]]. + ^out contents!
Item was added: + PlotMorph subclass: #RangeSelectablePlotMorph + instanceVariableNames: 'selectionStart selectionStop oldSelectionRectangle model' + classVariableNames: '' + poolDictionaries: '' + category: 'CogTools-VMProfiler'!
Item was added: + ----- Method: RangeSelectablePlotMorph class>>LICENSE (in category 'LICENSE') ----- + LICENSE + ^'Project Squeak + + Copyright (c) 2005-2013, 3D Immersive Collaboration Consulting, LLC., All Rights Reserved + + Redistributions in source code form must reproduce the above copyright and this condition. + + Licensed under MIT License (MIT) + Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + + The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + + THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.'!
Item was added: + ----- Method: RangeSelectablePlotMorph class>>model: (in category 'instance creation') ----- + model: aProfiler + ^self new model: aProfiler; yourself!
Item was added: + ----- Method: RangeSelectablePlotMorph>>drawOn: (in category 'drawing') ----- + drawOn: aCanvas + + super drawOn: aCanvas. + self selectionRectangle ifNotNil: + [:selectionRectangle| + aCanvas fillRectangle: selectionRectangle color: (Color lightBlue alpha: 0.5)].!
Item was added: + ----- Method: RangeSelectablePlotMorph>>invalidateSelection (in category 'selection') ----- + invalidateSelection + self selectionRectangle + ifNil: + [oldSelectionRectangle ifNotNil: + [self invalidRect: oldSelectionRectangle. + oldSelectionRectangle := nil]] + ifNotNil: + [:selectionRectangle| + self invalidRect: (oldSelectionRectangle + ifNil: [selectionRectangle] + ifNotNil: [oldSelectionRectangle merge: selectionRectangle]). + oldSelectionRectangle := selectionRectangle]!
Item was added: + ----- Method: RangeSelectablePlotMorph>>model (in category 'accessing') ----- + model + ^model!
Item was added: + ----- Method: RangeSelectablePlotMorph>>model: (in category 'accessing') ----- + model: anObject + "Set my model and make me me a dependent of the given object." + + model ifNotNil: [model removeDependent: self]. + anObject ifNotNil: [anObject addDependent: self]. + model := anObject!
Item was added: + ----- Method: RangeSelectablePlotMorph>>mouseDown: (in category 'event handling') ----- + mouseDown: anEvent + + selectionStart := anEvent position x. + self invalidateSelection!
Item was added: + ----- Method: RangeSelectablePlotMorph>>mouseMove: (in category 'event handling') ----- + mouseMove: anEvent + selectionStop := anEvent position x. + self invalidateSelection!
Item was added: + ----- Method: RangeSelectablePlotMorph>>mouseUp: (in category 'event handling') ----- + mouseUp: anEvent + | selectionRect screenDrawBounds range | + selectionRect := self selectionRectangle. + screenDrawBounds := self bounds insetBy: margin. + range := screenDrawBounds width asFloat. + selectionStart := selectionStop := nil. + self invalidateSelection. + (selectionRect notNil and: [model notNil]) + ifTrue: [model + selectProportionFrom: ((selectionRect left - screenDrawBounds left) / range max: 0.0) + to: ((selectionRect right - screenDrawBounds left) / range min: 1.0)].!
Item was added: + ----- Method: RangeSelectablePlotMorph>>selectionRectangle (in category 'selection') ----- + selectionRectangle + ^(selectionStart notNil and: [selectionStop notNil]) ifTrue: + [| bounds | + bounds := self bounds. + ((selectionStart min: selectionStop) max: bounds left)@bounds top + corner: ((selectionStart max: selectionStop) min: bounds right)@bounds bottom]!
Item was added: + ----- Method: SmalltalkImage>>quit (in category '*CogTools-Listener') ----- + quit + self snapshot: false andQuit: true!
Item was changed: ----- Method: SqueakVMProfiler>>threadIndexText: (in category 'accessing') ----- threadIndexText: aText
aText asString asInteger ifNotNil: [:integer | threadIndex := integer]. self initializeSamples. self computeHistograms. + self plotGraph. + self changed: #total.! - self plotGraph.!
Item was added: + Object subclass: #StdioListener + instanceVariableNames: 'quitOnEof stdin stdout stderr' + classVariableNames: '' + poolDictionaries: '' + category: 'CogTools-Listener'!
Item was added: + ----- Method: StdioListener>>initialize (in category 'initialize-release') ----- + initialize + quitOnEof := true. + stdin := FileStream stdin. + stdout := FileStream stdout. + stderr := FileStream stderr!
Item was added: + ----- Method: StdioListener>>logError:inContext:to: (in category 'run loop') ----- + logError: errMsg inContext: aContext to: aStream + aStream nextPutAll: errMsg; cr. + aContext errorReportOn: aStream. + aStream cr!
Item was added: + ----- Method: StdioListener>>quitOnEof (in category 'accessing') ----- + quitOnEof + ^quitOnEof!
Item was added: + ----- Method: StdioListener>>quitOnEof: (in category 'accessing') ----- + quitOnEof: aBoolean + quitOnEof := aBoolean!
Item was added: + ----- Method: StdioListener>>run (in category 'run loop') ----- + run + [stdin atEnd] whileFalse: + [| nextChunk | + stdout nextPutAll: 'squeak> '; flush. + nextChunk := stdin nextChunkNoTag. + [nextChunk notEmpty and: [nextChunk first isSeparator]] whileTrue: + [nextChunk := nextChunk allButFirst]. + Transcript cr; nextPutAll: nextChunk; cr; flush. + [stdout print: (Compiler evaluate: nextChunk); cr; flush] + on: Error + do: [:ex| self logError: ex description inContext: ex signalerContext to: stderr]]. + quitOnEof ifTrue: + [SourceFiles at: 2 put: nil. + Smalltalk snapshot: false andQuit: true]!
Item was added: + Model subclass: #ThreadInspector + instanceVariableNames: 'startTime ownerLog' + classVariableNames: '' + poolDictionaries: '' + category: 'CogTools-ThreadInspector'!
Item was added: + ----- Method: ThreadInspector>>getOwnerLogFromVM (in category 'accessing') ----- + getOwnerLogFromVM + + |bytes numElements bigEndian| + bytes := (ByteArray new: 3*8*1024). + numElements := self primitiveGetOwnerLog: bytes. + bigEndian := Smalltalk endianness = #big. + self assert: Smalltalk wordSize = 8. "TODO: Decode 32-bit VM log" + + ^ (0 to: numElements - 1) + collect: [:index | |bytesOffset| + bytesOffset := index * 24. + CogVMOwnerLog new + timestamp: (bytes long64At: bytesOffset + 1 bigEndian: bigEndian); "+1 because Smalltalk is 1-indexed" + vmOwner: (bytes long64At: bytesOffset + 9 bigEndian: bigEndian); + successfulSwitch: (bytes long64At: bytesOffset + 17 bigEndian: bigEndian) ~= 0; + yourself].!
Item was added: + ----- Method: ThreadInspector>>ownerLog (in category 'accessing') ----- + ownerLog + + ^ ownerLog!
Item was added: + ----- Method: ThreadInspector>>ownerLog: (in category 'accessing') ----- + ownerLog: anOrderedCollection + + ownerLog := anOrderedCollection.!
Item was added: + ----- Method: ThreadInspector>>primitiveGetOwnerLog: (in category 'primitives') ----- + primitiveGetOwnerLog: aByteArray + + <primitive: 226 error: ec> + ^ self primitiveFailed: ec!
Item was added: + ----- Method: ThreadInspector>>primitiveMillisecondsNow (in category 'primitives') ----- + primitiveMillisecondsNow + <primitive: 245> + ^ self primitiveFailed!
Item was added: + ----- Method: ThreadInspector>>spyOn: (in category 'as yet unclassified') ----- + spyOn: aBlock + + | newStartTime | + newStartTime := self primitiveMillisecondsNow. + + aBlock value. + + "Only update the startTime & ownerLog if the block succeeded." + self startTime: newStartTime. + self ownerLog: self getOwnerLogFromVM.!
Item was added: + ----- Method: ThreadInspector>>startTime (in category 'accessing') ----- + startTime + + ^ startTime!
Item was added: + ----- Method: ThreadInspector>>startTime: (in category 'accessing') ----- + startTime: aNumber + + startTime := aNumber.!
Item was added: + ----- Method: ThreadInspector>>visualize (in category 'as yet unclassified') ----- + visualize + + | pm startIndex lastVMOwner | + pm := ThreadInspectorPlotMorph new. + pm + series: #vmOwner color: Color green; + series: #vmOwner description: 'vm owner'; + series: #vmOwner type: #stepped. + + pm + series: #failedLocks color: Color red; + series: #failedLocks description: 'failed locking attempts'; + series: #failedLocks drawLine: false. + + startIndex := (self ownerLog findLast: [:entry | entry successfulSwitch and: [entry timestamp <= self startTime]]). + startIndex := startIndex max: 1. + startIndex to: self ownerLog size + do: [:index | |entry series | + entry := (self ownerLog at: index). + series := entry successfulSwitch ifTrue: [#vmOwner] ifFalse: [#failedLocks]. + pm series: series addPoint: entry timestamp @ entry vmOwner]. + lastVMOwner := (self ownerLog at: (self ownerLog findLast: [:entry | entry successfulSwitch])) vmOwner. + pm series: #vmOwner addPoint: self ownerLog last timestamp@ lastVMOwner. + "make sure we always have at least -1, 0 and 1 in view, even if there were no owner switches to them." + pm minPoint y > -1 + ifTrue: [pm limitMinY: -1]. + pm maxPoint y < 1 + ifTrue: [pm limitMaxY: 1]. + + pm openInWorld. + !
Item was added: + PlotMorphGrid subclass: #ThreadInspectorGrid + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'CogTools-ThreadInspector'!
Item was added: + ----- Method: ThreadInspectorGrid>>bestStep: (in category 'as yet unclassified') ----- + bestStep: height + + | maxY minY | + maxY := plot maxPoint y. + minY := plot minPoint y. + ^ height / (maxY - minY)!
Item was added: + ----- Method: ThreadInspectorGrid>>drawGridOn: (in category 'as yet unclassified') ----- + drawGridOn: aCanvas + + | gridColor lighter darker baseColor bounds | + baseColor := plot baseColor alpha: 1. + lighter := baseColor twiceLighter. + darker := baseColor twiceDarker. + gridColor := (lighter diff: baseColor) + > (darker diff: baseColor) + ifTrue: [lighter] + ifFalse: [darker]. + bounds := plot drawBounds. + (bounds top + to: bounds bottom + by: (self bestStep: bounds height)) + do: [:y | | yRounded | + yRounded := y rounded. + aCanvas + line: bounds left @ yRounded + to: bounds right @ yRounded + color: gridColor]!
Item was added: + RangeSelectablePlotMorph subclass: #ThreadInspectorPlotMorph + instanceVariableNames: '' + classVariableNames: '' + poolDictionaries: '' + category: 'CogTools-ThreadInspector'!
Item was added: + ----- Method: ThreadInspectorPlotMorph>>gridClass (in category 'as yet unclassified') ----- + gridClass + + ^ ThreadInspectorGrid!
Item was added: + ----- Method: ThreadInspectorPlotMorph>>moveYMidToZero (in category 'as yet unclassified') ----- + moveYMidToZero + "This is the most useful marker for thread inspection as 0 means 'disowned'." + | zeroFraction | + ymid contents: (yAxisFormatter value: 0). + + self assert: (self minPoint y < 0 and: [0 < self maxPoint y]). + + zeroFraction := self maxPoint y / (self maxPoint y - self minPoint y). + ymid position: (self topLeft + + ((15 - ymid width max: 0) @ (self height - ymid height * zeroFraction) rounded) + + (self borderWidth @ 0)).!
Item was added: + ----- Method: ThreadInspectorPlotMorph>>updateCotas (in category 'as yet unclassified') ----- + updateCotas + + super updateCotas. + (series notNil and: [self minPoint y < 0 and: [0 < self maxPoint y]]) + ifTrue: [self moveYMidToZero].!
Item was changed: + RangeSelectablePlotMorph subclass: #VMProfilePlotMorph + instanceVariableNames: 'alternateSeries cachedAlternateMaxPoint cachedAlternateMinPoint aymax aymid aymin' - PlotMorph subclass: #VMProfilePlotMorph - instanceVariableNames: 'alternateSeries selectionStart selectionStop oldSelectionRectangle model cachedAlternateMaxPoint cachedAlternateMinPoint aymax aymid aymin' classVariableNames: '' poolDictionaries: '' category: 'CogTools-VMProfiler'!
Item was removed: - ----- Method: VMProfilePlotMorph>>drawOn: (in category 'drawing') ----- - drawOn: aCanvas - self selectionRectangle ifNotNil: - [:selectionRectangle| - aCanvas fillRectangle: selectionRectangle color: Color lightBlue]. - super drawOn: aCanvas!
Item was removed: - ----- Method: VMProfilePlotMorph>>invalidateSelection (in category 'selection') ----- - invalidateSelection - self selectionRectangle - ifNil: - [oldSelectionRectangle ifNotNil: - [self invalidRect: oldSelectionRectangle. - oldSelectionRectangle := nil]] - ifNotNil: - [:selectionRectangle| - self invalidRect: (oldSelectionRectangle - ifNil: [selectionRectangle] - ifNotNil: [oldSelectionRectangle merge: selectionRectangle]). - oldSelectionRectangle := selectionRectangle]!
Item was removed: - ----- Method: VMProfilePlotMorph>>model (in category 'accessing') ----- - model - ^model!
Item was removed: - ----- Method: VMProfilePlotMorph>>model: (in category 'accessing') ----- - model: anObject - "Set my model and make me me a dependent of the given object." - - model ifNotNil: [model removeDependent: self]. - anObject ifNotNil: [anObject addDependent: self]. - model := anObject!
Item was removed: - ----- Method: VMProfilePlotMorph>>mouseDown: (in category 'event handling') ----- - mouseDown: anEvent - selectionStart := anEvent position x. - self invalidateSelection!
Item was removed: - ----- Method: VMProfilePlotMorph>>mouseMove: (in category 'event handling') ----- - mouseMove: anEvent - selectionStop := anEvent position x. - self invalidateSelection!
Item was removed: - ----- Method: VMProfilePlotMorph>>mouseUp: (in category 'event handling') ----- - mouseUp: anEvent - | selectionRect screenDrawBounds range | - selectionRect := self selectionRectangle. - screenDrawBounds := self bounds insetBy: margin. - range := screenDrawBounds width asFloat. - selectionStart := selectionStop := nil. - self invalidateSelection. - selectionRect ifNotNil: - [model - selectProportionFrom: ((selectionRect left - screenDrawBounds left) / range max: 0.0) - to: ((selectionRect right - screenDrawBounds left) / range min: 1.0)]!
Item was removed: - ----- Method: VMProfilePlotMorph>>selectionRectangle (in category 'selection') ----- - selectionRectangle - ^(selectionStart notNil and: [selectionStop notNil]) ifTrue: - [| bounds | - bounds := self bounds. - ((selectionStart min: selectionStop) max: bounds left)@bounds top - corner: ((selectionStart max: selectionStop) min: bounds right)@bounds bottom]!
Item was changed: ----- Method: VMProfiler>>putReportPreambleOn: (in category 'reports') ----- putReportPreambleOn: s | expr | s nextPutAll: (SmalltalkImage current getSystemAttribute: 0); space; nextPutAll: Date today yyyymmdd; space. Time now print24: true on: s. s cr. (startStats size >= 44 and: [(startStats at: 44) isNumber]) ifTrue: [s nextPutAll: 'eden size: '; nextPutAll: (startStats at: 44) asStringWithCommas. s nextPutAll: ' stack pages: '; print: (startStats at: 42). (startStats size >= 46 and: [(startStats at: 46) isNumber and: [(startStats at: 46) > 0]]) ifTrue: [s nextPutAll: ' code size: '; nextPutAll: (startStats at: 46) asStringWithCommas]. s cr]. + s nextPutAll: 'OS Thread: ', threadIndex. + threadIndex = 1 ifTrue: [s nextPutAll: ' (Heartbeat thread)']. s cr. + s cr. (expr := self trimmedExpressionText) notEmpty ifTrue: [s nextPutAll: expr; cr; cr]. (gcPriorToProfile or: [clearPriorToProfile or: [forkProfile]]) ifTrue: [gcPriorToProfile ifTrue: [s nextPutAll: 'gc prior. ']. clearPriorToProfile ifTrue: [s nextPutAll: 'clear prior. ']. forkProfile ifTrue: [s nextPutAll: 'run in separate process.']. s cr]. elapsedTime > 0 ifTrue: [s print: elapsedTime / 1000.0; nextPutAll: ' seconds; sampling frequency '; print: (total * 1000 / elapsedTime) rounded; nextPutAll: ' hz'; cr]!
vm-dev@lists.squeakfoundation.org