[Vm-dev] VM Maker: CogTools-sk.14.mcz
commits at source.squeak.org
commits at source.squeak.org
Tue May 16 16:49:13 UTC 2017
Sophie Kaleba uploaded a new version of CogTools to project VM Maker:
http://source.squeak.org/VMMaker/CogTools-sk.14.mcz
==================== Summary ====================
Name: CogTools-sk.14
Author: sk
Time: 16 May 2017, 6:49:04.728984 pm
UUID: e6587e5d-1b7d-49fb-bbff-c32c5e0f958b
Ancestors: CogTools-sk.13
make the profiler works on both squeak and pharo
==================== Snapshot ====================
SystemOrganization addCategory: #CogTools!
SystemOrganization addCategory: #'CogTools-VMProfiler'!
Object subclass: #PlotMorphGrid
instanceVariableNames: 'plot drawAxis drawGrid'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!PlotMorphGrid commentStamp: '<historical>' prior: 0!
I'm the grid of a PlotMorph!
----- Method: PlotMorphGrid class>>new (in category 'instance creation') -----
new
^ super new initialize!
----- Method: PlotMorphGrid class>>on: (in category 'instance creation') -----
on: aPlotMorph
^ self new initializeOn: aPlotMorph!
----- Method: PlotMorphGrid>>bestStep: (in category 'drawing') -----
bestStep: aNumber
"answer the best step for grid drawing"
| bestStep |
bestStep := aNumber.
2
to: 40
by: 2
do: [:i |
| step |
step := aNumber / i.
(step between: 25 and: 100)
ifTrue: [bestStep := step]].
^ bestStep!
----- Method: PlotMorphGrid>>drawAxis: (in category 'accessing') -----
drawAxis: aBoolean
drawAxis := aBoolean!
----- Method: PlotMorphGrid>>drawAxisOn: (in category 'drawing') -----
drawAxisOn: aCanvas
| axisColor yTo lighter darker baseColor bounds xTo |
baseColor := plot baseColor alpha: 1.
lighter := baseColor twiceLighter twiceLighter twiceLighter.
darker := baseColor twiceDarker twiceDarker twiceDarker.
axisColor := (lighter diff: baseColor)
> (darker diff: baseColor)
ifTrue: [lighter]
ifFalse: [darker].
""
bounds := plot drawBounds.
"Y axe"
yTo := bounds topLeft - (0 @ 7).
aCanvas
line: bounds bottomLeft + (0 @ 5)
to: yTo
color: axisColor.
aCanvas
line: yTo
to: yTo + (4 @ 4)
color: axisColor.
aCanvas
line: yTo
to: yTo + (-4 @ 4)
color: axisColor.
"X axe"
xTo := bounds bottomRight + (7 @ 0).
aCanvas
line: bounds bottomLeft - (5 @ 0)
to: xTo
color: axisColor.
aCanvas
line: xTo
to: xTo + (-4 @ -4)
color: axisColor.
aCanvas
line: xTo
to: xTo + (-4 @ 4)
color: axisColor!
----- Method: PlotMorphGrid>>drawGrid: (in category 'accessing') -----
drawGrid: aBoolean
drawGrid := aBoolean!
----- Method: PlotMorphGrid>>drawGridOn: (in category 'drawing') -----
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 left
to: bounds right
by: (self bestStep: bounds width))
do: [:x | | xRounded |
xRounded := x rounded.
aCanvas
line: xRounded @ bounds top
to: xRounded @ bounds bottom
color: gridColor].
(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]!
----- Method: PlotMorphGrid>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
drawGrid
ifTrue: [self drawGridOn: aCanvas].
drawAxis
ifTrue: [self drawAxisOn: aCanvas]!
----- Method: PlotMorphGrid>>initialize (in category 'initialization') -----
initialize
drawAxis := true.
drawGrid := true!
----- Method: PlotMorphGrid>>initializeOn: (in category 'initialization') -----
initializeOn: aPlotMorph
plot := aPlotMorph!
Object subclass: #PlotSeries
instanceVariableNames: 'name description color width points drawPoints drawLine drawArea type'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!PlotSeries commentStamp: '<historical>' prior: 0!
I'm a serie of a PlotMorph!
----- Method: PlotSeries class>>name: (in category 'instance creation') -----
name: aString
^ self new
initializeName: aString
!
----- Method: PlotSeries>>addPoint: (in category 'points') -----
addPoint: aPoint
points
add: (PlotPoint at: aPoint serie: self)!
----- Method: PlotSeries>>addPoint:extra: (in category 'points') -----
addPoint: aPoint extra:anObject
points
add: (PlotPoint at: aPoint serie: self extra:anObject)!
----- Method: PlotSeries>>areaColor (in category 'accessing-color') -----
areaColor
^ color alpha: 0.25!
----- Method: PlotSeries>>clear (in category 'accessing') -----
clear
points := OrderedCollection new!
----- Method: PlotSeries>>color (in category 'accessing') -----
color
^color!
----- Method: PlotSeries>>color: (in category 'accessing-color') -----
color: anObject
color := anObject!
----- Method: PlotSeries>>description (in category 'accessing') -----
description
^ description ifNil:[name]!
----- Method: PlotSeries>>description: (in category 'accessing') -----
description: aString
description := aString!
----- Method: PlotSeries>>drawArea: (in category 'accessing') -----
drawArea: aBoolean
drawArea := aBoolean!
----- Method: PlotSeries>>drawLine: (in category 'accessing') -----
drawLine: aBoolean
drawLine := aBoolean!
----- Method: PlotSeries>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
points isEmpty
ifTrue: [^ self].
""
drawArea
ifTrue: [""
type == #straightened
ifTrue: [self drawStraightenedAreaOn: aCanvas].
type == #stepped
ifTrue: [self drawSteppedAreaOn: aCanvas]].
drawLine
ifTrue: [""
type == #straightened
ifTrue: [self drawStraightenedLineOn: aCanvas].
type == #stepped
ifTrue: [self drawSteppedLineOn: aCanvas]].
drawPoints
ifTrue: [self drawPointsOn: aCanvas]!
----- Method: PlotSeries>>drawPoints: (in category 'accessing') -----
drawPoints: aBoolean
drawPoints := aBoolean!
----- Method: PlotSeries>>drawPointsOn: (in category 'drawing') -----
drawPointsOn: aCanvas
| pointColor minus plus |
pointColor := self pointColor.
minus := width @ width.
plus := minus * 2.
points
do: [:point |
| scaledPoint |
scaledPoint := point scaledPoint.
aCanvas
fillOval: (scaledPoint - minus rect: scaledPoint + plus)
color: pointColor]!
----- Method: PlotSeries>>drawSteppedAreaOn: (in category 'drawing') -----
drawSteppedAreaOn: aCanvas
| areaColor areaPoints lastScaledPoint |
areaColor := self areaColor.
areaPoints := OrderedCollection new.
lastScaledPoint := nil.
points
do: [:each |
| scaledPoint |
scaledPoint := each scaledPoint.
lastScaledPoint
ifNotNil: [areaPoints add: scaledPoint x @ lastScaledPoint y].
areaPoints add: scaledPoint.
lastScaledPoint := scaledPoint].
aCanvas
drawPolygon: areaPoints
color: areaColor
borderWidth: 0
borderColor: areaColor!
----- Method: PlotSeries>>drawSteppedLineOn: (in category 'drawing') -----
drawSteppedLineOn: aCanvas
| lineColor lastScaledPoint |
lineColor := self lineColor.
lastScaledPoint := nil.
points
do: [:point |
| scaledPoint |
scaledPoint := point scaledPoint.
lastScaledPoint
ifNotNil: [""aCanvas
line: lastScaledPoint
to: scaledPoint x @ lastScaledPoint y
width: width
color: lineColor.
aCanvas
line: scaledPoint x @ lastScaledPoint y
to: scaledPoint
width: width
color: lineColor].
lastScaledPoint := scaledPoint]!
----- Method: PlotSeries>>drawStraightenedAreaOn: (in category 'drawing') -----
drawStraightenedAreaOn: aCanvas
| areaColor |
areaColor := self areaColor.
aCanvas
drawPolygon: (points
collect: [:each | each scaledPoint])
color: areaColor
borderWidth: 0
borderColor: areaColor!
----- Method: PlotSeries>>drawStraightenedLineOn: (in category 'drawing') -----
drawStraightenedLineOn: aCanvas
| lineColor lastScaledPoint |
lineColor := self lineColor.
lastScaledPoint := nil.
points
do: [:point |
| scaledPoint |
scaledPoint := point scaledPoint.
lastScaledPoint
ifNotNil: [aCanvas
line: lastScaledPoint
to: scaledPoint
width: width
color: lineColor].
lastScaledPoint := scaledPoint]!
----- Method: PlotSeries>>initializeName: (in category 'initialization') -----
initializeName: aString
name := aString.
""
color := Color black.
""
width := 1.
drawPoints := true.
drawLine := true.
drawArea := false.
type := #straightened.
points := OrderedCollection new!
----- Method: PlotSeries>>lineColor (in category 'accessing-color') -----
lineColor
^ color
alpha: 0.85!
----- Method: PlotSeries>>maxPoint (in category 'points') -----
maxPoint
^ points isEmpty
ifTrue: [nil]
ifFalse: [points max]!
----- Method: PlotSeries>>minPoint (in category 'points') -----
minPoint
^ points isEmpty
ifTrue: [nil]
ifFalse: [points min]!
----- Method: PlotSeries>>name (in category 'accessing') -----
name
^ name!
----- Method: PlotSeries>>pointColor (in category 'accessing-color') -----
pointColor
^ color twiceLighter alpha: 0.85!
----- Method: PlotSeries>>points (in category 'accessing') -----
points
^points!
----- Method: PlotSeries>>printOn: (in category 'printing') -----
printOn: aStream
aStream nextPutAll: 'Serie:';
nextPutAll: name;
nextPutAll: ', color:';
nextPutAll: color asString;
nextPutAll: ', width:';
nextPutAll: width asString;
nextPutAll: ', drawPoints:';
nextPutAll: drawPoints asString;
nextPutAll: ', drawLine:';
nextPutAll: drawLine asString;
nextPutAll: ', drawArea:';
nextPutAll: drawArea asString!
----- Method: PlotSeries>>scaleTo:height:maxPoint:minPoint: (in category 'points') -----
scaleTo: anRectangle height: heightInteger maxPoint: maxPoint minPoint: minPoint
| drawExtent scaleFrom scaleTo|
drawExtent := 1 @ 1 max: maxPoint - minPoint.
drawExtent isZero ifTrue:[^ self].
""
scaleFrom := 0 @ 0 rect: drawExtent.
scaleTo := anRectangle.
points do:
[:point |
| tempPoint |
tempPoint := point - minPoint scaleFrom: scaleFrom to: scaleTo.
point scaledPoint: tempPoint x @ (heightInteger - tempPoint y)]!
----- Method: PlotSeries>>type: (in category 'accessing') -----
type: aSymbol
"Line Type (#straightened, #stepped)"
type := aSymbol!
----- Method: PlotSeries>>width: (in category 'accessing') -----
width: anObject
width := anObject!
Object subclass: #VMFileSystem
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMFileSystem commentStamp: 'SophieKaleba 5/15/2017 01:49' prior: 0!
I am a bridge between the file systems of Pharo and Squeak.
I am used in the VMProfiler to keep it generic.!
VMFileSystem subclass: #PharoVMFileSystem
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: PharoVMFileSystem>>ensureExistenceOfDirectory: (in category 'public') -----
ensureExistenceOfDirectory: aDirName
^ aDirName ensureCreateDirectory !
----- Method: PharoVMFileSystem>>exists: (in category 'public') -----
exists: aFilename
^ aFilename asFileReference exists!
----- Method: PharoVMFileSystem>>nameFordirPath:plus: (in category 'as yet unclassified') -----
nameFordirPath: aDirPath plus: aProcessId
^ (aDirPath, aProcessId) asFileReference !
----- Method: PharoVMFileSystem>>nameOfFile:in: (in category 'as yet unclassified') -----
nameOfFile: aFilename in: aDirectory
^ aFilename asFileReference basename !
----- Method: PharoVMFileSystem>>parentPathOfFile: (in category 'as yet unclassified') -----
parentPathOfFile: aFilename
^ (aFilename asFileReference) parent pathString !
VMFileSystem subclass: #SqueakVMFileSystem
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: SqueakVMFileSystem>>ensureExistenceOfDirectory: (in category 'public') -----
ensureExistenceOfDirectory: aDirName
^ aDirName assureExistence!
----- Method: SqueakVMFileSystem>>exists: (in category 'public') -----
exists: aFilename
^FileDirectory default fileExists: aFilename !
----- Method: SqueakVMFileSystem>>nameFordirPath:plus: (in category 'as yet unclassified') -----
nameFordirPath: aDirPath plus: aProcessId
^ FileDirectory on: aDirPath, aProcessId!
----- Method: SqueakVMFileSystem>>nameOfFile:in: (in category 'as yet unclassified') -----
nameOfFile: aFilename in: aDirectory
^ aDirectory localNameFor: aFilename !
----- Method: SqueakVMFileSystem>>parentPathOfFile: (in category 'as yet unclassified') -----
parentPathOfFile: aFilename
^ FileDirectory dirPathFor: aFilename !
----- Method: VMFileSystem>>ensureExistenceOfDirectory: (in category 'public') -----
ensureExistenceOfDirectory: aDirName
self subclassResponsibility !
----- Method: VMFileSystem>>exists: (in category 'public') -----
exists: aFilename
self subclassResponsibility !
----- Method: VMFileSystem>>nameFordirPath:plus: (in category 'as yet unclassified') -----
nameFordirPath: aDirPath plus: aProcessId
self subclassResponsibility !
----- Method: VMFileSystem>>nameOfFile:in: (in category 'as yet unclassified') -----
nameOfFile: aFilename in: aDirectory
self subclassResponsibility !
----- Method: VMFileSystem>>parentPathOfFile: (in category 'as yet unclassified') -----
parentPathOfFile: aFilename
self subclassResponsibility !
Object subclass: #VMGraphPlotter
instanceVariableNames: 'histogramSeries integralSeries startAddress integral plotAsBars'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMGraphPlotter commentStamp: 'eem 10/25/2016 11:33' prior: 0!
A VMGraphPlotter manages the details of adding points to the histogram and integral graphs in VMProfiler>>plotSamplesFrom:to:intoHistogram:andIntegral:!
----- Method: VMGraphPlotter>>addPlotFor:at: (in category 'plotting') -----
addPlotFor: sum at: address
sum = 0 ifTrue:
[(histogramSeries points notEmpty
and: [histogramSeries points last y > 0]) ifTrue:
[plotAsBars ifTrue:
[histogramSeries addPoint: address @ histogramSeries points last y].
histogramSeries addPoint: address @ 0].
^self].
histogramSeries points isEmpty
ifTrue:
[histogramSeries addPoint: startAddress @ 0.
address > startAddress ifTrue:
[histogramSeries addPoint: address @ 0]]
ifFalse:
[histogramSeries points last y = 0 ifTrue:
[histogramSeries addPoint: address @ 0]].
plotAsBars ifTrue:
[histogramSeries addPoint: address @ histogramSeries points last y].
histogramSeries addPoint: address @ sum.
integralSeries points isEmpty ifTrue:
[integralSeries addPoint: startAddress @ 0.
address > startAddress ifTrue:
[integralSeries addPoint: address @ 0]].
integral := integral + sum.
integralSeries addPoint: address @ integral!
----- Method: VMGraphPlotter>>histogram:integral:startAddress: (in category 'initialize-release') -----
histogram: histogramPlotSeries integral: integralPlotSeries startAddress: start
histogramSeries := histogramPlotSeries.
integralSeries := integralPlotSeries.
startAddress := start.
integral := 0.
plotAsBars := false!
----- Method: VMGraphPlotter>>plotAsBars (in category 'accessing') -----
plotAsBars
^plotAsBars!
----- Method: VMGraphPlotter>>plotAsBars: (in category 'accessing') -----
plotAsBars: aBoolean
plotAsBars := aBoolean!
Object subclass: #VMPSymbol
instanceVariableNames: 'name address limit'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMPSymbol commentStamp: '<historical>' prior: 0!
A text symbol in the VM's address space corresponding to some form of executable code (see subclasses)!
VMPSymbol subclass: #VMPExecutableModuleSymbol
instanceVariableNames: 'vmshift shortName'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMPExecutableModuleSymbol commentStamp: '<historical>' prior: 0!
A symbol for some sort of executable, e.g. the VM or a dynamically loaded library it is using. The vmshift inst var is the amount (if any) the text segment of the module has been moved in memory from its static definition.!
----- Method: VMPExecutableModuleSymbol 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.'!
----- Method: VMPExecutableModuleSymbol>>displayText (in category 'printing') -----
displayText
^(name copyFrom: (name lastIndexOf: FileDirectory pathNameDelimiter) + 1 to: name size) asText allBold!
----- Method: VMPExecutableModuleSymbol>>hash (in category 'comparing') -----
hash
"Override to avoid hashing on the address. This avoids multiple entries for
modules in the symbol manager's symbolsByModule dictionary. Lazy initialization
in the symbol manager may change a module's address after parsing its symbols."
^self class hash bitXor: name hash!
----- Method: VMPExecutableModuleSymbol>>importance (in category 'comparing') -----
importance
^0!
----- Method: VMPExecutableModuleSymbol>>nameMatches: (in category 'testing') -----
nameMatches: aPattern
^(super nameMatches: aPattern)
or: [shortName notNil and: [aPattern match: shortName]]!
----- Method: VMPExecutableModuleSymbol>>shortName (in category 'accessing') -----
shortName
"Answer the value of shortName"
^ shortName!
----- Method: VMPExecutableModuleSymbol>>shortName: (in category 'accessing') -----
shortName: aString
"Set the value of shortName"
shortName := aString!
----- Method: VMPExecutableModuleSymbol>>type (in category 'accessing') -----
type
^#module!
----- Method: VMPExecutableModuleSymbol>>vmshift (in category 'accessing') -----
vmshift
"Answer the value of vmshift"
^ vmshift!
----- Method: VMPExecutableModuleSymbol>>vmshift: (in category 'accessing') -----
vmshift: anObject
"Set the value of vmshift"
vmshift := anObject!
VMPSymbol subclass: #VMPFunctionSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMPFunctionSymbol commentStamp: '<historical>' prior: 0!
A symbol for a function or procedure (see subclasses)!
----- Method: VMPFunctionSymbol 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.'!
VMPFunctionSymbol subclass: #VMPPrivateFunctionSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMPPrivateFunctionSymbol commentStamp: '<historical>' prior: 0!
A symbol for a function or procedure private to an object or module!
----- Method: VMPPrivateFunctionSymbol 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.'!
----- Method: VMPPrivateFunctionSymbol>>importance (in category 'comparing') -----
importance
^2!
----- Method: VMPPrivateFunctionSymbol>>type (in category 'accessing') -----
type
^#privateFunction!
VMPFunctionSymbol subclass: #VMPPublicFunctionSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMPPublicFunctionSymbol commentStamp: '<historical>' prior: 0!
A symbol for a public function or procedure exported from some module!
----- Method: VMPPublicFunctionSymbol 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.'!
----- Method: VMPPublicFunctionSymbol>>importance (in category 'comparing') -----
importance
^1!
----- Method: VMPPublicFunctionSymbol>>type (in category 'accessing') -----
type
^#publicFunction!
VMPSymbol subclass: #VMPLabelSymbol
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: VMPLabelSymbol 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.'!
----- Method: VMPLabelSymbol>>importance (in category 'comparing') -----
importance
^4!
----- Method: VMPLabelSymbol>>limit (in category 'accessing') -----
limit
"Answer the address. labels are point entities"
^address!
----- Method: VMPLabelSymbol>>limit: (in category 'accessing') -----
limit: aValue
"Ignore. labels are point entities"!
----- Method: VMPLabelSymbol>>type (in category 'accessing') -----
type
^#label!
----- Method: VMPSymbol 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.'!
----- Method: VMPSymbol class>>defaultIntegerBaseInDebugger (in category 'debugger') -----
defaultIntegerBaseInDebugger
^16!
----- Method: VMPSymbol>>= (in category 'comparing') -----
= anObject
^self class == anObject class
and: [address = anObject address
and: [name = anObject name]]!
----- Method: VMPSymbol>>address (in category 'accessing') -----
address
"Answer the value of address"
^ address!
----- Method: VMPSymbol>>address: (in category 'accessing') -----
address: anObject
"Set the value of address"
address := anObject!
----- Method: VMPSymbol>>displayText (in category 'printing') -----
displayText
"Answer the name as a string, which for the purposes of the symbol list is an unemphasized text."
^name!
----- Method: VMPSymbol>>hash (in category 'comparing') -----
hash
^address hash bitXor: name hash!
----- Method: VMPSymbol>>importance (in category 'comparing') -----
importance
^self subclassResponsibility!
----- Method: VMPSymbol>>limit (in category 'accessing') -----
limit
"Answer the value of limit"
^ limit!
----- Method: VMPSymbol>>limit: (in category 'accessing') -----
limit: anObject
"Set the value of limit"
anObject - address > 2097152 ifTrue:
[Transcript cr; nextPutAll: name; space; print: anObject - address; tab; nextPutAll: (anObject - address) hex; flush.
"self halt"].
limit := anObject
"VMProfilerMacSymbolsManager basicNew initializeSynchronously"!
----- Method: VMPSymbol>>name (in category 'accessing') -----
name
"Answer the value of name"
^name!
----- Method: VMPSymbol>>name: (in category 'accessing') -----
name: anObject
"Set the value of name"
name := anObject!
----- Method: VMPSymbol>>nameMatches: (in category 'testing') -----
nameMatches: aPattern
^aPattern match: name!
----- Method: VMPSymbol>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
[aStream space; nextPut: $(; nextPutAll: self type; space; nextPutAll: name; space.
address printOn: aStream base: 16.
(limit ~~ nil
and: [limit ~= address]) ifTrue:
[aStream nextPut: $-.
limit printOn: aStream base: 16].
aStream nextPut: $)]
on: Error
do: [:ex| aStream print: ex; nextPut: $)]!
----- Method: VMPSymbol>>size: (in category 'accessing') -----
size: size
limit := address + size!
----- Method: VMPSymbol>>type (in category 'accessing') -----
type
^self subclassResponsibility!
Object subclass: #VMProfilerSymbolsManager
instanceVariableNames: 'modules symbolsByModule modulesByName vmModule cogModule'
classVariableNames: 'fileSystem'
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
VMProfilerSymbolsManager subclass: #VMProfilerLinuxSymbolsManager
instanceVariableNames: 'initialized tempDir maxAddressMask warnInconsistentShift'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: VMProfilerLinuxSymbolsManager 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.'!
----- Method: VMProfilerLinuxSymbolsManager class>>defaultIntegerBaseInDebugger (in category 'debugger') -----
defaultIntegerBaseInDebugger
^16!
----- Method: VMProfilerLinuxSymbolsManager class>>initialize (in category 'class initialization') -----
initialize
"Add to the shut down list to delete the temp directory and contents."
Smalltalk addToShutDownList: self!
----- Method: VMProfilerLinuxSymbolsManager class>>shutDown: (in category 'shut down') -----
shutDown: quitting
(quitting
and: [#('Mac OS' 'unix') includes: Smalltalk platformName]) ifTrue:
[| tempDir |
(tempDir := self tempDirectory) exists ifTrue:
[tempDir recursiveDelete]]!
----- Method: VMProfilerLinuxSymbolsManager class>>tempDirectory (in category 'as yet unclassified') -----
tempDirectory
^ fileSystem nameFordirPath:'/tmp/vmsyms' plus:OSProcess thisOSProcess pid printString
!
----- Method: VMProfilerLinuxSymbolsManager>>hexFromStream: (in category 'parsing') -----
hexFromStream: aStream
"Fast reading of lower-case hexadecimal."
| value index |
value := 0.
[nil ~~ (index := '0123456789abcdef' indexOf: aStream next ifAbsent: nil)] whileTrue:
[value := (value bitShift: 4) + index - 1].
^value
"(self basicNew hexFromStream: '91a45000' readStream) hex"!
----- Method: VMProfilerLinuxSymbolsManager>>initialize (in category 'initialize-release') -----
initialize
"Initialize the receiver, parsing the symbols in the background for faster startup."
self initializeMost.
self parseAsynchronously!
----- Method: VMProfilerLinuxSymbolsManager>>initializeMost (in category 'initialize-release') -----
initializeMost
| shortNames |
initialized := false.
maxAddressMask := (2 raisedToInteger: 32) - 1.
modulesByName := Dictionary new.
symbolsByModule := Dictionary new.
shortNames := Set new.
tempDir := self class tempDirectory.
self fileSystem ensureExistenceOfDirectory: tempDir.
modules := self primitiveExecutableModules.
modules := (1 to: modules size by: 2) collect:
[:i| | fileName shortName counter longName |
fileName := modules at: i.
(fileName beginsWith: '/dgagent') ifTrue:
[fileName := fileName allButFirst: 8].
shortName := fileSystem nameOfFile: fileName in: tempDir.
counter := 0.
[shortNames includes: shortName] whileTrue:
[counter := counter + 1.
shortName := (fileSystem nameOfFile: fileName in: tempDir), counter printString].
shortNames add: shortName.
longName := (modules at: i + 1)
ifNil: [fileName]
ifNotNil:
[:symlink|
symlink first = $/
ifTrue: [symlink]
ifFalse: [( fileSystem parentPathOfFile: fileName ), '/', symlink]].
"some files are off limits (e.g. /dgagent/lib/preload.so)"
(fileSystem exists: longName) ifTrue:
[(modulesByName
at: longName
put: VMPExecutableModuleSymbol new)
name: longName;
shortName: shortName]].
"The primitive always answers the VM info in the first entry."
vmModule := modules first.
"now filter out the files we can't read..."
modules := modules select: [:m| modulesByName includesKey: m name]!
----- Method: VMProfilerLinuxSymbolsManager>>initializeSynchronously (in category 'initialize-release') -----
initializeSynchronously
"Initialize the receiver, parsing the symbols in the foreground for debugging."
self initializeMost.
self parseSynchronously!
----- Method: VMProfilerLinuxSymbolsManager>>initialized (in category 'accessing') -----
initialized
^initialized!
----- Method: VMProfilerLinuxSymbolsManager>>parseAsynchronously (in category 'parsing') -----
parseAsynchronously
"Parse the symbols in the background for faster startup."
"Parse only the VM module. The profiler needs this initialized early."
symbolsByModule at: vmModule put: { vmModule }.
self parseSymbolsFor: vmModule.
"Kick-off a process to compute the symbol list for each module. Parsing symbols
can take a few seconds so we parse in the background."
[modules allButFirst do:
[:module|
symbolsByModule at: module put: { module }.
self parseSymbolsFor: module.
module address ifNil: [symbolsByModule removeKey: module]].
modules := (modules reject: [:m| m address isNil]) asSortedCollection: [:m1 :m2| m1 address <= m2 address].
initialized := true] forkAt: Processor userBackgroundPriority!
----- Method: VMProfilerLinuxSymbolsManager>>parseSymbolsFor: (in category 'parsing') -----
parseSymbolsFor: module
| proc symtab symStream |
(fileSystem exists: tempDir fullName, '/', module shortName) ifFalse:
[proc := OSProcess thisOSProcess command:
'objdump -j .text -tT "', module name, '" | fgrep .text | sort >"', tempDir fullName, '/', module shortName, '"'].
symStream := (Array new: 1000) writeStream.
symStream nextPut: module.
proc ifNotNil:
[[proc isComplete] whileFalse: [(Delay forMilliseconds: 25) wait]].
symtab := [StandardFileStream readOnlyFileNamed: (tempDir fullName,'/',module shortName) ]
on: Error
do: [:ex| "Handle flaky OSProcess stuff by reporting error and failing to parse"
Transcript print: ex; flush.
^nil].
[| prev |
prev := self parseSymbolsFrom: symtab to: symStream.
symbolsByModule
at: module
put: (self relocateSymbols: symStream contents allButFirst inModule: module).
(prev notNil
and: [prev limit isNil]) ifTrue: [prev limit: module limit]]
ensure: [symtab close]!
----- Method: VMProfilerLinuxSymbolsManager>>parseSymbolsFrom:to: (in category 'parsing') -----
parseSymbolsFrom: symtab "<ReadStream>" to: symStream "<WriteStream> ^<VMPSymbol>"
"Parse the text symbols on the stream symtab (in objdump format) to symStream.
Answer the last text symbol."
| prev |
[symtab atEnd] whileFalse:
[| line tokens address size type symbol |
tokens := (line := symtab upTo: Character lf) substrings.
self assert: (tokens size between: 5 and: 7).
self assert: ((tokens size = 5 and: [tokens third = '.text']) "labels"
or: [tokens fourth = '.text']) "functions".
address := Integer readFrom: tokens first readStream radix: 16.
size := tokens size = 5
ifTrue: [0] "labels"
ifFalse: [Integer readFrom: tokens fifth readStream radix: 16].
type := tokens second.
symbol := (type = 'g'
ifTrue: [VMPPublicFunctionSymbol]
ifFalse:
[(tokens last beginsWith: '.L')
ifTrue: [VMPLabelSymbol]
ifFalse: [VMPPrivateFunctionSymbol]]) new.
symbol
name: tokens last;
address: address;
limit: address + size.
(prev isNil or: [prev ~= symbol]) ifTrue:
[symStream nextPut: symbol].
prev := symbol].
^prev!
----- Method: VMProfilerLinuxSymbolsManager>>parseSynchronously (in category 'parsing') -----
parseSynchronously
modules do:
[:module|
symbolsByModule at: module put: { module }.
self parseSymbolsFor: module.
module address ifNil: [symbolsByModule removeKey: module]].
modules := (modules reject: [:m| m address isNil]) asSortedCollection: [:m1 :m2| m1 address <= m2 address].
initialized := true!
----- Method: VMProfilerLinuxSymbolsManager>>primitiveDLSym:in: (in category 'primitives') -----
primitiveDLSym: symbolName in: libraryName
<primitive: 'primitiveDLSymInLibrary' module: 'VMProfileLinuxSupportPlugin' error: ec>
ec == #'not found' ifTrue:
[^nil].
^self primitiveFailed!
----- Method: VMProfilerLinuxSymbolsManager>>primitiveExecutableModules (in category 'primitives') -----
primitiveExecutableModules
"Answer an Array of pairs of strings for executable modules (the VM executable and
loaded libraries). The first element in each pair is the filename of the module. The
second element is either nil or the symlink's target, if the filename is a symlink."
<primitive: 'primitiveExecutableModules' module: 'VMProfileLinuxSupportPlugin'>
^self primitiveFailed
"self basicNew primitiveExecutableModules"!
----- Method: VMProfilerLinuxSymbolsManager>>primitiveInterpretAddress (in category 'primitives') -----
primitiveInterpretAddress
"Answer the address of the interpret routine. Used to compute the address shift, if any, of the VM module."
<primitive: 'primitiveInterpretAddress' module: 'VMProfileLinuxSupportPlugin'>
^self primitiveFailed
"self basicNew primitiveInterpretAddress"!
----- Method: VMProfilerLinuxSymbolsManager>>relocateSymbols:inModule: (in category 'parsing') -----
relocateSymbols: symbols inModule: module
"We can't trust the shift that comes from the dyld_get_image_header call in
primitiveExecutableModulesAndOffsets. So use dlsym to find out the actual
address of the first real symbol and use that to compute the real shift.
At least some libraries (e.g. /usr/lib/libSystem.B.dylib) don't have a single shift (!!!!).
Check, and compensate by calling dlsym on each symbol."
| shift count prev |
symbols isEmpty ifTrue: [^symbols]. "avoid symbols first exception"
shift := module = vmModule
ifTrue:
[self primitiveInterpretAddress - (symbols detect: [:s| s name = 'interpret']) address]
ifFalse:
[(symbols detect: [:sym|
sym type == #publicFunction
and: [(self primitiveDLSym: sym name in: module name) notNil]] ifNone: [])
ifNil: [Transcript cr; show: 'warning, can''t find any public symbols in ', module name.
0]
ifNotNil:
[:symbol| (self primitiveDLSym: symbol name in: module name) - symbol address]].
module address ifNil:
[module
address: symbols first address + shift;
limit: symbols last limit + shift].
shift = 0 ifTrue:
[count := 0.
symbols do: [:s| (s address between: module address and: module limit) ifTrue: [count := count + 1]].
count = symbols size ifTrue:
[^symbols]. "don't waste time..."
count ~= 0 ifTrue:
[self error: 'parse error; some symbols within module, some without'].
shift := module address].
(prev := symbols first) address: (maxAddressMask bitAnd: symbols first address + shift).
symbols do:
[:sym| | reloc |
prev ~~ sym ifTrue:
[reloc := maxAddressMask bitAnd: sym address + shift.
sym address: reloc.
prev limit: reloc].
prev := sym].
symbols last limit: (symbols last limit
ifNil: [module limit]
ifNotNil: [:limit| maxAddressMask bitAnd: limit + shift]).
^symbols!
VMProfilerSymbolsManager subclass: #VMProfilerMacSymbolsManager
instanceVariableNames: 'initialized tempDir maxAddressMask warnInconsistentShift'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: VMProfilerMacSymbolsManager 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.'!
----- Method: VMProfilerMacSymbolsManager class>>defaultIntegerBaseInDebugger (in category 'debugger') -----
defaultIntegerBaseInDebugger
^16!
----- Method: VMProfilerMacSymbolsManager class>>initialize (in category 'class initialization') -----
initialize
"Add to the shut down list to delete the temp directory and contents."
Smalltalk addToShutDownList: self!
----- Method: VMProfilerMacSymbolsManager class>>shutDown: (in category 'shut down') -----
shutDown: quitting
(quitting
and: [Smalltalk platformName= 'Mac OS']) ifTrue:
[| tempDir |
(tempDir := self tempDirectory) exists ifTrue:
[tempDir recursiveDelete]]!
----- Method: VMProfilerMacSymbolsManager class>>tempDirectory (in category 'as yet unclassified') -----
tempDirectory
^ fileSystem nameFordirPath:'private/tmp/vmsyms' plus:OSProcess thisOSProcess pid printString
!
----- Method: VMProfilerMacSymbolsManager>>archName (in category 'parsing') -----
archName
"Answer the architecture name for use with nm, size et al."
^(Smalltalk image getSystemAttribute: 1003) caseOf: {
['intel'] -> ['i386'].
['x64'] -> ['x86_64'] }!
----- Method: VMProfilerMacSymbolsManager>>computeLimitFor:initialShift: (in category 'parsing') -----
computeLimitFor: module initialShift: initialShift
"If we can't find a non-text symbol following the last text symbol, compute the ernd of text using the size command."
| sizeFileName proc text size |
sizeFileName := module shortName, '.size'.
(fileSystem exists: tempDir, '/', sizeFileName) ifFalse:
["N.B. Don't use the -f option (which meant flat symbols) as in El Capitan it is misinterpreted to mean -format."
proc := OSProcess thisOSProcess command:
'cd ', tempDir fullName,
';size -arch ', self archName, " -f" ' "', module name, '" >"', sizeFileName, '"'.
[proc isComplete] whileFalse: [(Delay forMilliseconds: 25) wait]].
text := (StandardFileStream readOnlyFileNamed: (tempDir fullNameFor: sizeFileName)) contentsOfEntireFile.
size := Integer readFrom: (text copyAfter: Character lf) readStream.
^size + initialShift!
----- Method: VMProfilerMacSymbolsManager>>filter: (in category 'initialize-release') -----
filter: moduleList
"Some modules are giving us parsing problems at the moment. Just ignore them for now."
^moduleList reject: [:t| #('CoreAUC' 'FaceCore' 'HIToolbox' 'VideoToolbox') anySatisfy: [:s| t name includesSubstring: s]]!
----- Method: VMProfilerMacSymbolsManager>>hexFromStream: (in category 'parsing') -----
hexFromStream: aStream
"Fast reading of lower-case hexadecimal."
| value index |
value := 0.
[nil ~~ (index := '0123456789abcdef' indexOf: aStream next ifAbsent: nil)] whileTrue:
[value := (value bitShift: 4) + index - 1].
^value
"(self basicNew hexFromStream: '91a45000' readStream) hex"!
----- Method: VMProfilerMacSymbolsManager>>initialize (in category 'initialize-release') -----
initialize
"Initialize the receiver, parsing the symbols in the background for faster startup."
self initializeMost.
self parseAsynchronously!
----- Method: VMProfilerMacSymbolsManager>>initializeMost (in category 'initialize-release') -----
initializeMost
| shortNames |
initialized := false.
maxAddressMask := (2 raisedToInteger: Smalltalk wordSize * 8) - 1.
modulesByName := Dictionary new.
symbolsByModule := Dictionary new.
shortNames := Set new.
modules := self primitiveExecutableModulesAndOffsets.
tempDir := self class tempDirectory.
self fileSystem ensureExistenceOfDirectory: tempDir.
modules := (1 to: modules size by: 4) collect:
[:i| | shortName counter |
shortName := fileSystem nameOfFile: (modules at: i) in: tempDir.
counter := 0.
[shortNames includes: shortName] whileTrue:
[counter := counter + 1.
shortName := (fileSystem nameOfFile: (modules at: i) in: tempDir), counter printString].
shortNames add: shortName.
(modulesByName
at: (modules at: i)
put: VMPExecutableModuleSymbol new)
name: (modules at: i);
shortName: shortName;
vmshift: (modules at: i + 1);
address: (maxAddressMask bitAnd: (modules at: i + 2) + (modules at: i + 1));
size: (modules at: i + 3)].
modules := self filter: modules.
"The primitive always answers the VM info in the first entry."
vmModule := modules first.
modules := modules asSortedCollection: [:m1 :m2| m1 address <= m2 address]!
----- Method: VMProfilerMacSymbolsManager>>initializeSynchronously (in category 'initialize-release') -----
initializeSynchronously
"Initialize the receiver, parsing the symbols in the foreground for debugging."
self initializeMost.
self parseSynchronously!
----- Method: VMProfilerMacSymbolsManager>>initialized (in category 'accessing') -----
initialized
^initialized!
----- Method: VMProfilerMacSymbolsManager>>parseAsynchronously (in category 'parsing') -----
parseAsynchronously
"Parse the symbols in the background for faster startup."
"Parse only the VM module. The profiler needs this initialized early."
symbolsByModule at: vmModule put: { vmModule }.
self parseSymbolsFor: vmModule.
"Kick-off a process to compute the symbol list for each module. Parsing symbols
can take a few seconds so we parse in the background."
[modules allButFirst do:
[:module|
symbolsByModule at: module put: { module }.
(self parseSymbolsFor: module) ifNil:
[symbolsByModule removeKey: module]].
initialized := true] forkAt: Processor userBackgroundPriority!
----- Method: VMProfilerMacSymbolsManager>>parseSymbolsFor: (in category 'parsing') -----
parseSymbolsFor: module
| proc symtab symStream |
(fileSystem exists: tempDir fullName, '/', module shortName) ifFalse:
"(tempDir fileExists: module shortName) ifFalse:"
["N.B. Don't use the -f option (which meant flat symbols) as in El Capitan it is misinterpreted to mean -format."
proc := OSProcess thisOSProcess command:
'cd ', tempDir fullName,
';nm -n -arch ', self archName, " -f" ' "', module name, '" | grep -v " [aAU] " >"', module shortName, '"'].
symStream := (Array new: 1000) writeStream.
symStream nextPut: module.
proc ifNotNil:
[[proc isComplete] whileFalse: [(Delay forMilliseconds: 25) wait]].
symtab := [StandardFileStream readOnlyFileNamed: (tempDir fullName, '/', module shortName)]
on: Error
do: [:ex| "Handle flaky OSProcess stuff by reporting error and failing to parse"
Transcript print: ex; flush.
^nil].
"Have caller eliminate modules with no text."
symtab size = 0 ifTrue:
[^nil].
module shortName = 'HIToolbox' ifTrue: [self halt].
[| prev |
prev := self parseSymbolsFrom: symtab to: symStream.
"CoreAUC has a huge chunk of data at the end of its text segment that causes the profiler to spend ages
counting zeros. Hack fix by setting the end of the last symbol in the text segment to a little less than 1Mb."
"00000000000f1922 retq" "Mavericks 13.4"
"00000000000f3b21 retq" "Yosemite 14.5"
module shortName = 'CoreAUC' ifTrue: [prev limit: 16rf8000].
symbolsByModule
at: module
put: (self relocateSymbols: symStream contents allButFirst inModule: module).
(prev notNil
and: [prev limit isNil]) ifTrue: [prev limit: module limit]]
ensure: [symtab close]!
----- Method: VMProfilerMacSymbolsManager>>parseSymbolsFrom:to: (in category 'parsing') -----
parseSymbolsFrom: symtab "<ReadStream>" to: symStream "<WriteStream> ^<VMPSymbol>"
"Parse the text symbols on the stream symtab (in nm format) to symStream.
Answer the last text symbol."
| space lf prev |
space := Character space.
lf := Character lf.
[symtab atEnd] whileFalse:
[| line ch address |
line := (symtab upTo: lf) readStream.
line skipSeparators.
((ch := line peek) notNil
and: [ch ~= space
and: [(address := self hexFromStream: line) ~= maxAddressMask
and: [address ~= 0 "on 10.6 this eliminates initial mh_dylib_header entries"]]]) ifTrue:
[| symbol |
prev ifNotNil:
[prev limit: address].
('Tt' includes: line peek)
ifTrue:
[| public |
public := line next == $T.
line skipTo: space.
symbol := (line peek == $L
ifTrue: [VMPLabelSymbol]
ifFalse:
[public
ifTrue: [VMPPublicFunctionSymbol]
ifFalse: [VMPPrivateFunctionSymbol]]) new.
line peek = $_ ifTrue: "Get rid of initial underscore."
[line next]. "N.B. relied upon by primitiveDLSym: below"
symbol
name: line upToEnd;
address: address.
symStream nextPut: symbol.
symbol type ~~ #label ifTrue:
[prev := symbol]]
ifFalse: "first non-text symbol marks the end of the text segment"
[symtab setToEnd]]].
^prev!
----- Method: VMProfilerMacSymbolsManager>>parseSynchronously (in category 'parsing') -----
parseSynchronously
modules do:
[:module|
symbolsByModule at: module put: { module }.
self parseSymbolsFor: module].
initialized := true!
----- Method: VMProfilerMacSymbolsManager>>primitiveDLSym: (in category 'primitives') -----
primitiveDLSym: symbolNameString
<primitive: 'primitiveDLSym' module: 'VMProfileMacSupportPlugin' error: ec>
^self primitiveFailed!
----- Method: VMProfilerMacSymbolsManager>>primitiveExecutableModulesAndOffsets (in category 'primitives') -----
primitiveExecutableModulesAndOffsets
"Answer an Array of pairs of executable module names (the VM executable and
all loaded libraries) and the vm address relocation, if any, is for the module."
<primitive: 'primitiveExecutableModulesAndOffsets' module: 'VMProfileMacSupportPlugin'>
^self primitiveFailed
"self basicNew primitiveExecutableModulesAndOffsets"!
----- Method: VMProfilerMacSymbolsManager>>relocateAndFilter:in:initialShift: (in category 'parsing') -----
relocateAndFilter: symbols in: module initialShift: initialShift
"We can't trust the shift that comes from the dyld_get_image_header call in
primitiveExecutableModulesAndOffsets. So use dlsym to find out the actual
address of the first real symbol and use that to compute the real shift.
At least some libraries (e.g. /usr/lib/libSystem.B.dylib) don't have a single shift (!!!!).
For these we have to call dlsym on each symbol."
| shift prev lastSize |
prev := nil.
shift := initialShift.
symbols last limit ifNil:
[symbols last limit: (self computeLimitFor: module initialShift: initialShift)].
symbols do:
[:s| | address |
lastSize := s limit ifNotNil: [:limit| limit - s address].
s type == #publicFunction
ifTrue:
[(address := self primitiveDLSym: s name)
ifNil: [s address: nil]
ifNotNil:
[(address between: module address and: module limit)
ifTrue:
[prev notNil ifTrue:
[prev limit: address].
shift := address - s address.
s address: address]
ifFalse: "duplicate symbol from some other library"
[address := maxAddressMask bitAnd: s address + shift.
s address: address.
prev ifNotNil: [prev limit: address].
prev := s].
prev := s]]
ifFalse:
[address := maxAddressMask bitAnd: s address + shift.
s address: address.
prev ifNotNil: [prev limit: address].
prev := s]].
prev limit: (lastSize ifNotNil: [prev address + lastSize] ifNil: [module limit]).
^symbols select: [:s| s address notNil]!
----- Method: VMProfilerMacSymbolsManager>>relocateSymbols:inModule: (in category 'parsing') -----
relocateSymbols: symbols inModule: module
"We can't trust the shift that comes from the dyld_get_image_header call in
primitiveExecutableModulesAndOffsets. So use dlsym to find out the actual
address of the first real symbol and use that to compute the real shift.
At least some libraries (e.g. /usr/lib/libSystem.B.dylib) don't have a single shift (!!!!).
Check, and compensate by calling dlsym on each symbol."
| shift i incr count prev |
symbols isEmpty ifTrue: [^symbols]. "avoid symbols first exception"
shift := (symbols detect: [:sym|
sym type == #publicFunction
and: [(self primitiveDLSym: sym name) notNil]] ifNone: [])
ifNil: [module vmshift]
ifNotNil:
[:symbol| (self primitiveDLSym: symbol name) - symbol address].
"Need to check for inconsistentshifts, because its faster by several seconds overall
if we can relocate using a single shift. But we can only lookup public symbols."
i := 2.
incr := warnInconsistentShift ifNil: [symbols size // 50 max: 1] ifNotNil: [1].
[i <= symbols size] whileTrue:
[(symbols at: i) type == #publicFunction
ifTrue:
[(self primitiveDLSym: (symbols at: i) name) ifNotNil:
[:addr|
addr - (symbols at: i) address ~= shift ifTrue:
[warnInconsistentShift == true ifTrue:
[Transcript cr; print: module shortName; nextPutAll: ' contains symbols with inconsistent shift'; flush].
^self relocateAndFilter: symbols in: module initialShift: shift]].
i := i + incr]
ifFalse: "not public; can't look it up; so skip it"
[i := i + 1]].
warnInconsistentShift == false ifTrue:
[Transcript cr; print: module shortName; nextPutAll: ' contains symbols with a consistent shift'; flush].
shift = 0 ifTrue:
[count := 0.
symbols do: [:s| (s address between: module address and: module limit) ifTrue: [count := count + 1]].
count = symbols size ifTrue:
[^symbols]. "don't waste time..."
count ~= 0 ifTrue:
[self error: 'parse error; some symbols within module, some without'].
shift := module address].
(prev := symbols first) address: (maxAddressMask bitAnd: symbols first address + shift).
symbols do:
[:sym| | reloc |
prev ~~ sym ifTrue:
[reloc := maxAddressMask bitAnd: sym address + shift.
sym address: reloc.
prev limit: reloc].
prev := sym].
symbols last limit: (symbols last limit
ifNil: [module limit]
ifNotNil: [:limit| maxAddressMask bitAnd: limit + shift]).
^symbols!
----- Method: VMProfilerSymbolsManager 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.'!
----- Method: VMProfilerSymbolsManager class>>using: (in category 'as yet unclassified') -----
using: aFileSystem
fileSystem := aFileSystem.
^ self new
!
----- Method: VMProfilerSymbolsManager>>addCogModuleSymbols: (in category 'Cog compiled code') -----
addCogModuleSymbols: symbols
self initialized ifFalse:
[(Delay forMilliseconds: 1000) wait].
modules
removeAllSuchThat: [:existingModule| cogModule name = existingModule name];
add: cogModule.
modulesByName at: cogModule name put: cogModule.
symbolsByModule at: cogModule put: symbols!
----- Method: VMProfilerSymbolsManager>>cogModule (in category 'accessing') -----
cogModule
^cogModule!
----- Method: VMProfilerSymbolsManager>>computeCogCodeModule: (in category 'Cog compiled code') -----
computeCogCodeModule: cogCodeConstituents
| symbols |
(cogModule := VMPExecutableModuleSymbol new)
name: vmModule shortName, '.', cogCodeConstituents first;
shortName: cogCodeConstituents first;
vmshift: 0;
address: cogCodeConstituents second;
size: cogCodeConstituents last - cogCodeConstituents second.
symbols := (3 to: cogCodeConstituents size - 2 by: 2) collect:
[:i| "Declare methods as public; PICs and entries as private"
| thing |
((thing := cogCodeConstituents at: i) isCompiledMethod
ifTrue: [VMPPublicFunctionSymbol]
ifFalse: [VMPPrivateFunctionSymbol]) new
name: (thing isCompiledMethod
ifTrue: [thing methodClass name, '>>', thing selector]
ifFalse: [thing class == cogCodeConstituents first class
ifTrue: [thing]
ifFalse: ['PIC ', (thing isString
ifTrue: [thing]
ifFalse: [thing printString])]]);
address: (cogCodeConstituents at: i + 1);
limit: (cogCodeConstituents at: i + 3 ifAbsent: [cogCodeConstituents last])].
self addCogModuleSymbols: symbols!
----- Method: VMProfilerSymbolsManager>>fileSystem (in category 'accessing') -----
fileSystem
^fileSystem !
----- Method: VMProfilerSymbolsManager>>fileSystem: (in category 'accessing') -----
fileSystem: aVMFileSystem
fileSystem := aVMFileSystem. !
----- Method: VMProfilerSymbolsManager>>moduleFor: (in category 'accessing') -----
moduleFor: aSymbol
^modules
detect: [:module|
module address <= aSymbol address
and: [module limit >= aSymbol limit]]
ifNone: []!
----- Method: VMProfilerSymbolsManager>>moduleForAddress: (in category 'accessing') -----
moduleForAddress: address
^modules
detect: [:module|
module address <= address
and: [module limit >= address]]
ifNone: []!
----- Method: VMProfilerSymbolsManager>>modules (in category 'accessing') -----
modules
^modules!
----- Method: VMProfilerSymbolsManager>>symbolsInModule: (in category 'accessing') -----
symbolsInModule: aModule
^symbolsByModule at: aModule ifAbsent: [#()]!
----- Method: VMProfilerSymbolsManager>>symbolsSelect: (in category 'accessing') -----
symbolsSelect: aBlock
| size stream |
size := symbolsByModule inject: 0 into: [:sum :symbols| sum + symbols size].
stream := (Array new: size) writeStream.
modules do:
[:module|
(aBlock value: module) ifTrue:
[stream nextPut: module].
(symbolsByModule at: module ifAbsent: [#()]) do:
[:sym|
(aBlock value: sym) ifTrue:
[stream nextPut: sym]]].
^stream contents!
----- Method: VMProfilerSymbolsManager>>symbolsWithTypes: (in category 'accessing') -----
symbolsWithTypes: aSet
| size stream |
(aSet size = 1 and: [aSet anyOne == #module]) ifTrue:
[^modules].
size := symbolsByModule inject: 0 into: [:sum :symbols| sum + symbols size].
stream := (Array new: size) writeStream.
modules do:
[:module|
(symbolsByModule at: module ifAbsent: [#()]) do:
[:sym|
(aSet includes: sym type) ifTrue:
[stream nextPut: sym]]].
^stream contents!
----- Method: VMProfilerSymbolsManager>>vmModule (in category 'accessing') -----
vmModule
^vmModule!
PluggableListMorph subclass: #PluggableListMorphOfManyAlt
instanceVariableNames: 'dragOnOrOff getSelectionListSelector setSelectionListSelector currentRow'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!PluggableListMorphOfManyAlt commentStamp: '<historical>' prior: 0!
A variant of its superclass that allows multiple items to be selected simultaneously. There is still a distinguished element which is selected, but each other element in the list may be flagged on or off. This is a clone of PluggableListMorphOfMany that sends the changePrimarySelection: selector only when the mouse is first pushed and sends the changeListSelection: selector while the mouse is being dragged. This allows the model to choose to respond to a new selection by deselecting existing selections. This differs from PluggableListMorphOfMany which sends both selectors all the time.!
----- Method: PluggableListMorphOfManyAlt class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:getListElement:menu: (in category 'instance creation') -----
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel getListElement: listElemSel menu: getMenuSel
^ self new
on: anObject
list: listSel
primarySelection: getSelectionSel
changePrimarySelection: setSelectionSel
listSelection: getListSel
changeListSelection: setListSel
getListElement: listElemSel
menu: getMenuSel
keystroke: #arrowKey:from: "default"!
----- Method: PluggableListMorphOfManyAlt class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu: (in category 'instance creation') -----
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel
^ self new
on: anObject
list: listSel
primarySelection: getSelectionSel
changePrimarySelection: setSelectionSel
listSelection: getListSel
changeListSelection: setListSel
getListElement: nil "default"
menu: getMenuSel
keystroke: #arrowKey:from: "default"!
----- Method: PluggableListMorphOfManyAlt class>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:menu:keystroke: (in category 'instance creation') -----
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel menu: getMenuSel keystroke: keyActionSel
^ self new
on: anObject
list: listSel
primarySelection: getSelectionSel
changePrimarySelection: setSelectionSel
listSelection: getListSel
changeListSelection: setListSel
getListElement: nil "default"
menu: getMenuSel
keystroke: keyActionSel!
----- Method: PluggableListMorphOfManyAlt>>getList (in category 'model access') -----
getList
"Answer the list to be displayed. Caches the returned list in the 'list' ivar"
getListSelector == nil ifTrue: [^ #()].
list := model perform: getListSelector.
list == nil ifTrue: [^ #()].
getListElementSelector ifNil:
[list := list collect: [ :item | item asStringOrText ]].
^ list!
----- Method: PluggableListMorphOfManyAlt>>itemSelectedAmongMultiple: (in category 'model access') -----
itemSelectedAmongMultiple: index
^self listSelectionAt: index!
----- Method: PluggableListMorphOfManyAlt>>list: (in category 'initialization') -----
list: listOfStrings
scroller removeAllMorphs.
list := listOfStrings ifNil: [Array new].
list isEmpty ifTrue: [^ self selectedMorph: nil].
super list: listOfStrings.
"At this point first morph is sensitized, and all morphs share same handler."
scroller firstSubmorph on: #mouseEnterDragging
send: #mouseEnterDragging:onItem:
to: self.
scroller firstSubmorph on: #mouseUp
send: #mouseUp:onItem:
to: self.
"This should add this behavior to the shared event handler thus affecting all items"!
----- Method: PluggableListMorphOfManyAlt>>listSelectionAt: (in category 'drawing') -----
listSelectionAt: index
getSelectionListSelector ifNil:[^false].
^model perform: getSelectionListSelector with: index!
----- Method: PluggableListMorphOfManyAlt>>listSelectionAt:put: (in category 'drawing') -----
listSelectionAt: index put: value
setSelectionListSelector ifNil:[^false].
^model perform: setSelectionListSelector with: index with: value!
----- Method: PluggableListMorphOfManyAlt>>mouseDown: (in category 'event handling') -----
mouseDown: event
| oldIndex oldVal row |
Transcript cr; show: 'mouseDown:'.
event yellowButtonPressed ifTrue: [^ self yellowButtonActivity: event shiftPressed].
row := self rowAtLocation: event position.
row = 0 ifTrue: [^super mouseDown: event].
model okToChange ifFalse: [^ self]. "No change if model is locked"
"Set meaning for subsequent dragging of selection"
dragOnOrOff := (self listSelectionAt: row) not.
currentRow := row.
oldIndex := self getCurrentSelectionIndex.
oldVal := oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex] ifFalse: [false].
"Need to restore the old one, due to how model works, and set new one."
oldIndex ~= 0 ifTrue: [self listSelectionAt: oldIndex put: oldVal].
"Set or clear new primary selection (listIndex)"
self listSelectionAt: row put: oldVal not!
----- Method: PluggableListMorphOfManyAlt>>mouseMove: (in category 'event handling') -----
mouseMove: event
"The mouse has moved, as characterized by the event provided. Adjust the scrollbar, and alter the selection as appropriate"
| row |
Transcript cr; show: 'mouseMove:'.
event position y < self top
ifTrue:
[scrollBar scrollUp: 1.
row := self rowAtLocation: scroller topLeft + (1 @ 1)]
ifFalse:
[row := event position y > self bottom
ifTrue:
[scrollBar scrollDown: 1.
self rowAtLocation: scroller bottomLeft + (1 @ -1)]
ifFalse: [ self rowAtLocation: event position]].
row = 0 ifTrue: [^super mouseDown: event].
model okToChange ifFalse: [^self]. "No change if model is locked"
currentRow = row ifTrue:
[^self].
currentRow := row.
dragOnOrOff ifNil:
["Don't treat a mouse move immediately after a mouse down to the same index."
row = self getCurrentSelectionIndex ifTrue: [^self].
"Was not set at mouse down, which means the mouse must have gone down in an area where there was no list item"
dragOnOrOff := (self listSelectionAt: row) not].
"Set or clear new primary selection (listIndex)"
dragOnOrOff
ifTrue: [self changeModelSelection: row]
ifFalse: [self changeModelSelection: 0].
row changed!
----- Method: PluggableListMorphOfManyAlt>>mouseUp: (in category 'event handling') -----
mouseUp: event
dragOnOrOff := nil. "So improperly started drags will have no effect"
currentRow := nil "So mouseMove won't trigger more than once"!
----- Method: PluggableListMorphOfManyAlt>>on:list:primarySelection:changePrimarySelection:listSelection:changeListSelection:getListElement:menu:keystroke: (in category 'initialization') -----
on: anObject list: listSel primarySelection: getSelectionSel changePrimarySelection: setSelectionSel listSelection: getListSel changeListSelection: setListSel getListElement: listElemSel menu: getMenuSel keystroke: keyActionSel
"setup a whole load of pluggability options"
getSelectionListSelector := getListSel.
setSelectionListSelector := setListSel.
getListElementSelector := listElemSel.
self on: anObject list: listSel selected: getSelectionSel changeSelected: setSelectionSel menu: getMenuSel keystroke: keyActionSel
!
----- Method: PluggableListMorphOfManyAlt>>scrollSelectionIntoView (in category 'selection') -----
scrollSelectionIntoView
"Make sure that the current selection is visible.
If the selections() will fit in the scroll region then scroll the selection(s)
to the middle of the visible region. If it is larger, make the first part visible."
| row rowBounds innerBounds i |
(row := self getCurrentSelectionIndex) = 0 ifTrue:
[^self].
rowBounds := self listMorph drawBoundsForRow: row.
innerBounds := self innerBounds.
i := row + 1.
[(model perform: getSelectionListSelector with: i)
and: [(self listMorph drawBoundsForRow: i) bottom - rowBounds top < innerBounds height]] whileTrue:
[i := i + 1].
rowBounds := rowBounds merge: (self listMorph drawBoundsForRow: i - 1).
self scrollToShow: (innerBounds align: innerBounds center with: rowBounds center)!
----- Method: PluggableListMorphOfManyAlt>>update: (in category 'updating') -----
update: aSymbol
aSymbol == #allSelections ifTrue:
[^self updateList; selectionIndex: self getCurrentSelectionIndex].
^super update: aSymbol!
Model subclass: #VMProfiler
instanceVariableNames: 'sampleBuffer sampleBag sortedSamples sortedSymbols sortedSymbolsBeforeCogCode sortedSymbolsAfterCogCode symbolsMode symbolTypes symbolManager symbolList selections minSelectionIndex maxSelectionIndex total rangeTotal highAddress lowAddress history historyIndex expressionTextMorph previousPattern graph aboutToProfile startTime elapsedTime startStats elapsedStats clearPriorToProfile gcPriorToProfile forkProfile cogCodeConstituents version fileSystem'
classVariableNames: 'CannedBenchmarkStrings'
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!VMProfiler commentStamp: 'eem 7/9/2013 14:08' prior: 0!
This tool is a pc-sampling profiler for the VM. It presents the profile data graphically.
Copyright© 2011-2013, 3D ICC Immersive Collaboration. All rights reserved.
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.
Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software distributed under the License is distributed on an "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the License for the specific language governing permissions and limitations under the License.!
VMProfiler subclass: #PharoVMProfiler
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: PharoVMProfiler class>>amOnSpur (in category 'reports') -----
amOnSpur
^(Smalltalk vm parameterAt: 41) anyMask: 16.!
----- Method: PharoVMProfiler class>>default (in category 'accessing') -----
default
"will do something when I take care of the UI"
^self new. !
----- Method: PharoVMProfiler>>createParagraph (in category 'as yet unclassified') -----
createParagraph
^Paragraph new!
----- Method: PharoVMProfiler>>getVMParameters (in category 'as yet unclassified') -----
getVMParameters
^Smalltalk vm getParameters !
VMProfiler subclass: #SqueakVMProfiler
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: SqueakVMProfiler class>>amOnSpur (in category 'reports') -----
amOnSpur
^(Smalltalk vmParameterAt: 41) anyMask: 16!
----- Method: SqueakVMProfiler class>>default (in category 'instance creation') -----
default
^self openInstance!
----- Method: SqueakVMProfiler class>>open (in category 'instance creation') -----
open
^self new openInWindow!
----- Method: SqueakVMProfiler class>>openInstance (in category 'instance creation') -----
openInstance
| window |
window := World submorphs
detect: [:sm| sm isSystemWindow and: [sm label = 'VMProfiler']]
ifNone: [self open].
^window model!
----- Method: SqueakVMProfiler class>>report: (in category 'spying') -----
report: aStream
"Compatibility with MessageTally and AndreasSystemProfiler instance side spyOn: & report:"
^self openInstance report: aStream!
----- Method: SqueakVMProfiler class>>spyOn: (in category 'spying') -----
spyOn: aBlock
"Compatibility with MessageTally and AndreasSystemProfiler instance side spyOn: & report:"
^Cursor execute showWhile:
[self openInstance spyOn: aBlock]!
----- Method: SqueakVMProfiler>>addToHistory (in category 'selecting') -----
addToHistory
historyIndex < history size ifTrue:
[history := history copyFrom: 1 to: historyIndex].
(history isEmpty or: [history last ~= (lowAddress to: highAddress)]) ifTrue:
[history addLast: (lowAddress to: highAddress).
historyIndex := history size].
!
----- Method: SqueakVMProfiler>>addressTextMorph:get:set: (in category 'opening') -----
addressTextMorph: help get: getter set: setter
| ptm |
ptm := PluggableTextMorph
on: self
text: getter accept: setter
readSelection: nil menu: nil.
ptm setProperty: #alwaysAccept toValue: true;
askBeforeDiscardingEdits: false;
acceptOnCR: true;
setBalloonText: help;
retractableOrNot;
hideOrShowScrollBars;
setProperty: #noScrollBarPlease toValue: true;
setProperty: #noVScrollBarPlease toValue: true.
^ptm!
----- Method: SqueakVMProfiler>>backwardsButton (in category 'opening') -----
backwardsButton
^ImageMorph new image: ((ScriptingSystem formAtKey: #playMPEG) flipBy: #horizontal centerAt: 0 at 0)!
----- Method: SqueakVMProfiler>>buttonMorph:help:set:enable:color: (in category 'opening') -----
buttonMorph: getLabelMessage help: help set: setter enable: enabler color: colorGetter
| pbm |
pbm := PluggableButtonMorphPlus on: self getState: nil action: setter label: getLabelMessage.
pbm
useRoundedCorners;
getEnabledSelector: enabler;
setBalloonText: help;
getColorSelector: colorGetter;
offColor: Color transparent.
^pbm!
----- Method: SqueakVMProfiler>>checkMorph:get:set: (in category 'opening') -----
checkMorph: help get: getter set: setter
| checkBoxButton |
checkBoxButton := UpdatingThreePhaseButtonMorph checkBox.
#(onImage pressedImage offImage)
with: #(onImage: pressedImage: offImage:)
do: [:get :set| | form |
((form := checkBoxButton perform: get) isColorForm
and: [form colors last = Color white]) ifTrue:
[checkBoxButton
perform: set
with: ((checkBoxButton perform: get) copy
colors: {Color transparent. Color black};
yourself)]].
^checkBoxButton
target: self;
actionSelector: setter;
getSelector: getter;
setBalloonText: help;
yourself!
----- Method: SqueakVMProfiler>>clearButton (in category 'buttons') -----
clearButton
"just weird..."
^'clear'!
----- Method: SqueakVMProfiler>>clearColor (in category 'buttons') -----
clearColor
^Color lightBlue!
----- Method: SqueakVMProfiler>>clearPriorToProfile (in category 'buttons') -----
clearPriorToProfile
^clearPriorToProfile!
----- Method: SqueakVMProfiler>>clearProfile (in category 'profiling') -----
clearProfile
super clearProfile.
self updateButtons. !
----- Method: SqueakVMProfiler>>createParagraph (in category 'as yet unclassified') -----
createParagraph
^NewParagraph new!
----- Method: SqueakVMProfiler>>drawButton (in category 'buttons') -----
drawButton
"just weird..."
^'plot'!
----- Method: SqueakVMProfiler>>expressionTextMenu: (in category 'menus') -----
expressionTextMenu: aMenuMorph
| expression |
expression := self trimmedExpressionText.
(expression isEmpty
or: [CannedBenchmarkStrings includes: expression]) ifFalse:
[aMenuMorph add: 'add text to benchmarks' target: self class selector: #canBenchmark: argument: expression].
aMenuMorph add: 'inspect canned benchmarks' target: ToolSet selector: #inspect: argument: CannedBenchmarkStrings.
CannedBenchmarkStrings isEmpty ifTrue:
[^aMenuMorph].
aMenuMorph addLine.
CannedBenchmarkStrings do:
[:benchmark|
aMenuMorph add: (benchmark contractTo: 60) target: self selector: #selectBenchmark: argument: benchmark].
^aMenuMorph!
----- Method: SqueakVMProfiler>>findSymbol:event: (in category 'menus') -----
findSymbol: typeOrNil event: event
| pattern matches selection anIndex |
previousPattern ifNil:
[previousPattern := '*'].
pattern := UIManager default
request: 'Symbol or pattern to find'
initialAnswer: previousPattern.
pattern isEmpty ifTrue: [^self].
previousPattern := pattern.
matches := symbolManager symbolsSelect:
(typeOrNil
ifNotNil:
[(pattern includesAnyOf: '#*')
ifTrue: [[:sym|
sym type == typeOrNil
and: [sym nameMatches: pattern]]]
ifFalse: [[:sym|
sym type == typeOrNil
and: [sym name
includesSubstring: pattern
caseSensitive: false]]]]
ifNil:
[(pattern includesAnyOf: '#*')
ifTrue: [[:sym| sym nameMatches: pattern]]
ifFalse: [[:sym| sym name
includesSubstring: pattern
caseSensitive: false]]]).
matches isEmpty ifTrue:
[^UIManager inform: 'No symbols match your query'].
matches size = 1
ifTrue: [selection := matches first]
ifFalse:
[matches := matches asSortedCollection:
[:s1 :s2| | sd1 sd2 |
(sd1 := s1 displayText) asString < (sd2 := s2 displayText) asString
or: [sd1 = sd2 and: [s1 address <= s2 address]]].
selection := (SelectionMenu
labelList: {'Choose symbol'},
(matches collect:
[:ea|
ea type == #module
ifTrue: [ea displayText]
ifFalse: [ea displayText, ' @', (ea address printStringRadix: 16),
' in ', (symbolManager moduleFor: ea) displayText]])
lines: {1}
selections: {nil}, matches) startUp.
selection ifNil: [^self]].
(symbolTypes includes: selection type) ifFalse:
[self toggleShowing: selection type].
minSelectionIndex := 0.
1 to: symbolList size do:
[:i|
selections
at: i
put: (((symbolList at: i) address >= selection address
and: [(symbolList at: i) limit <= selection limit])
ifTrue: [minSelectionIndex = 0 ifTrue: [minSelectionIndex := i].
maxSelectionIndex := i.
1]
ifFalse: [0])].
self changed: #symbolList.
self addToHistory.
"If selecting a label make sure there's not a zero address range so
select from the previous non-label symbol to the following non-label symbol"
selection address = selection limit
ifTrue: [anIndex := minSelectionIndex.
[(symbolList at: anIndex) type == #label
and: [anIndex > 1]] whileTrue: [anIndex := anIndex - 1].
lowAddress := (symbolList at: anIndex) address.
anIndex := maxSelectionIndex.
[(symbolList at: anIndex) type == #label
and: [anIndex < symbolList size]] whileTrue: [anIndex := anIndex + 1].
highAddress := (symbolList at: anIndex) address]
ifFalse:
[lowAddress := selection address.
highAddress := selection limit].
self updateAddressDependents;
updateButtons;
plotGraph!
----- Method: SqueakVMProfiler>>forkProfile (in category 'buttons') -----
forkProfile
^forkProfile!
----- Method: SqueakVMProfiler>>forwardsButton (in category 'opening') -----
forwardsButton
^ImageMorph new image: (ScriptingSystem formAtKey: #playMPEG)!
----- Method: SqueakVMProfiler>>gcPriorToProfile (in category 'buttons') -----
gcPriorToProfile
^gcPriorToProfile!
----- Method: SqueakVMProfiler>>getVMParameters (in category 'as yet unclassified') -----
getVMParameters
^Smalltalk getVMParameters !
----- Method: SqueakVMProfiler>>graphMargin (in category 'accessing') -----
graphMargin
^graph margin!
----- Method: SqueakVMProfiler>>hasFuture (in category 'selecting') -----
hasFuture
^historyIndex < history size!
----- Method: SqueakVMProfiler>>hasFutureColor (in category 'buttons') -----
hasFutureColor
^self hasFuture ifTrue: [Color transparent] ifFalse: [Color darkGray]!
----- Method: SqueakVMProfiler>>hasHistory (in category 'selecting') -----
hasHistory
^historyIndex >= 1!
----- Method: SqueakVMProfiler>>hasHistoryColor (in category 'buttons') -----
hasHistoryColor
^self hasHistory ifTrue: [Color transparent] ifFalse: [Color darkGray]!
----- Method: SqueakVMProfiler>>highAddressText (in category 'accessing') -----
highAddressText
^((highAddress printStringRadix: 16) allButFirst: 3) asText!
----- Method: SqueakVMProfiler>>highAddressText: (in category 'accessing') -----
highAddressText: aText
highAddress := ((Integer readFrom: aText asString asUppercase readStream base: 16) max: 0) min: self highestAddress.
self selectSymbolsInRange!
----- Method: SqueakVMProfiler>>highestAddress (in category 'sorting') -----
highestAddress
^(sortedSamples isEmpty
ifTrue: [symbolManager modules last limit]
ifFalse: [symbolManager modules last limit max: sortedSamples last key]) asPowerOfTwo - 1!
----- Method: SqueakVMProfiler>>historyButtonMorph:help:set:enable:color: (in category 'opening') -----
historyButtonMorph: getLabelMessage help: help set: setter enable: enabler color: colorGetter
| pbm |
pbm := PluggableButtonMorphPlus on: self getState: nil action: setter label: getLabelMessage.
pbm
getEnabledSelector: enabler;
setBalloonText: help;
getColorSelector: colorGetter;
offColor: Color transparent.
^pbm!
----- Method: SqueakVMProfiler>>labelFont (in category 'opening') -----
labelFont
"Answer the font in which to draw the graph labels.
N.B. the labelling morph shrinks this font by half when displaying."
^(TextStyle named: 'BitstreamVeraSans') fontOfPointSize: 16!
----- Method: SqueakVMProfiler>>lowAddressText (in category 'accessing') -----
lowAddressText
^((lowAddress printStringRadix: 16) allButFirst: 3) asText!
----- Method: SqueakVMProfiler>>lowAddressText: (in category 'accessing') -----
lowAddressText: aText
lowAddress := ((Integer readFrom: aText asString asUppercase readStream base: 16) max: 0) min: 16rFFFFFFFF.
self selectSymbolsInRange!
----- Method: SqueakVMProfiler>>notProfiling (in category 'profiling') -----
notProfiling
^self profiling not!
----- Method: SqueakVMProfiler>>notProfilingAndData (in category 'profiling') -----
notProfilingAndData
^sampleBuffer notNil and: [self notProfiling]!
----- Method: SqueakVMProfiler>>openInWindow (in category 'opening') -----
openInWindow
"VMProfiler open"
| window symbolListMorph labelsMorph buttons |
(window := SystemWindow new)
setProperty: #allowPaneSplitters toValue: false;
model: self;
setLabel: self class name;
fillStyle: Color white;
paneColor: Color white;
color: Color white.
(window respondsTo: #allowPaneSplitters:) ifTrue:
[window allowPaneSplitters: false].
"Cope with Squeak 4.1 SystemWindow background color changes"
window addMorph: (AlignmentMorph new color: Color white; yourself) frame: (0 at 0 corner: 1 at 1).
symbolListMorph := PluggableListMorphOfManyAlt
on: self
list: #symbolList
primarySelection: #symbolIndex
changePrimarySelection: #toggleListIndex:
listSelection: #symbolSelectionAt:
changeListSelection: #symbolSelectionAt:put:
getListElement: #listEntryForIndex:
menu: #symbolListMenu:.
symbolListMorph showHScrollBarOnlyWhenNeeded: false. "buggy misnamed selector :)"
labelsMorph := VMProfileGraphLabelMorph model: self font: self labelFont getLabels: #positionedLabels.
expressionTextMorph := PluggableTextMorph
on: self
text: nil accept: nil
readSelection: #selectionRange
menu: #expressionTextMenu:.
expressionTextMorph
setProperty: #alwaysAccept toValue: true;
askBeforeDiscardingEdits: false;
setBalloonText: 'type an expression to profile here'.
buttons := OrderedCollection new.
window
addMorph: symbolListMorph frame: (0 at 0 corner: 0.15 at 1);
addMorph: (graph := VMProfilePlotMorph model: self) frame: (0.15 at 0 corner: 1.0 at 0.7);
addMorph: labelsMorph frame: (0.15 at 0.7 corner: 1.0 at 0.85);
"address boxes"
addMorph: (self addressTextMorph:'Type the low address of the histogram here'
get: #lowAddressText
set: #lowAddressText:)
frame: (0.16 at 0.86 corner: 0.27 at 0.91);
addMorph: (self addressTextMorph:'Type the high address of the histogram here'
get: #highAddressText
set: #highAddressText:)
frame: (0.88 at 0.86 corner: 0.99 at 0.91);
addMorph: (self totalTextMorph: 'Shows the total number of samples' get: #totalText)
frame: (0.88 at 0.92 corner: 0.99 at 0.98);
"symbol list check-box filters"
addMorph: (self checkMorph: 'show module symbols'
get: #showingModules
set: #toggleShowModules)
frame: (0.16 at 0.915 corner: 0.175 at 0.93);
addMorph: (buttons addLast: (StringMorph contents: 'modules'))
frame: (0.19 at 0.915 corner: 0.27 at 0.93);
addMorph: (self checkMorph: 'show extern symbols'
get: #showingPublicFunctions
set: #toggleShowPublicFunctions)
frame: (0.16 at 0.935 corner: 0.175 at 0.95);
addMorph: (buttons addLast: (StringMorph contents: 'externs'))
frame: (0.19 at 0.935 corner: 0.27 at 0.95);
addMorph: (self checkMorph: 'show static symbols'
get: #showingPrivateFunctions
set: #toggleShowPrivateFunctions)
frame: (0.16 at 0.955 corner: 0.175 at 0.97);
addMorph: (buttons addLast: (StringMorph contents: 'statics'))
frame: (0.19 at 0.955 corner: 0.27 at 0.97);
addMorph: (self checkMorph: 'show static symbols'
get: #showingLabels
set: #toggleShowLabels)
frame: (0.16 at 0.975 corner: 0.175 at 0.99);
addMorph: (buttons addLast: (StringMorph contents: 'labels'))
frame: (0.19 at 0.975 corner: 0.27 at 0.99);
"history buttons"
addMorph: (self historyButtonMorph: #backwardsButton help: 'go back to previous selection'
set: #regress enable: #hasHistory color: #hasHistoryColor)
frame: (0.28 at 0.86 corner: 0.315 at 0.90);
addMorph: (self historyButtonMorph: #forwardsButton help: 'go forward to next selection'
set: #progress enable: #hasFuture color: #hasFutureColor)
frame: (0.32 at 0.86 corner: 0.355 at 0.90);
"profiling buttons"
addMorph: (self buttonMorph: #drawButton help: 'plot the graph'
set: #plotGraph enable: #notProfilingAndData color: #clearColor)
frame: (0.37 at 0.86 corner: 0.45 at 0.91);
addMorph: (self buttonMorph: #clearButton help: 'clear the histogram data'
set: #clearProfile enable: #notProfiling color: #clearColor)
frame: (0.46 at 0.86 corner: 0.54 at 0.91);
addMorph: (self buttonMorph: #startButton help: 'start the profiler'
set: #startProfiling enable: #notProfiling color: #profileColor)
frame: (0.28 at 0.915 corner: 0.36 at 0.96);
addMorph: (self buttonMorph: #stopButton help: 'stop the profiler'
set: #stopProfiling enable: #profiling color: #stopColor)
frame: (0.37 at 0.915 corner: 0.45 at 0.96);
addMorph: (self buttonMorph: #profileExpressionButton help: 'compile and profile the expression to the right'
set: #profileExpression enable: #notProfiling color: #profileColor)
frame: (0.46 at 0.915 corner: 0.54 at 0.96);
addMorph: expressionTextMorph
frame: (0.55 at 0.86 corner: 0.87 at 0.98);
addMorph: (self checkMorph: 'Run the full garbage collector prior to profiling'
get: #gcPriorToProfile
set: #toggleGcPriorToProfile)
frame: (0.28 at 0.97 corner: 0.295 at 0.985);
addMorph: (buttons addLast: (StringMorph contents: 'gc prior'))
frame: (0.30 at 0.97 corner: 0.365 at 0.995);
addMorph: (self checkMorph: 'Clear the profile prior to profiling'
get: #clearPriorToProfile
set: #toggleClearPriorToProfile)
frame: (0.37 at 0.97 corner: 0.385 at 0.985);
addMorph: (buttons addLast: (StringMorph contents: 'clear prior'))
frame: (0.39 at 0.97 corner: 0.455 at 0.995);
addMorph: (self checkMorph: 'Run the profiled expression in its own process'
get: #forkProfile
set: #toggleForkProfile)
frame: (0.46 at 0.97 corner: 0.475 at 0.985);
addMorph: (buttons addLast: (StringMorph contents: 'fork profile'))
frame: (0.48 at 0.97 corner: 0.545 at 0.995).
.
"A Color transparent fillStyle used to be the default. What a
pain that things change so radically from release to release!!"
graph fillStyle: Color transparent.
self updateButtons. "weird!!"
buttons do: [:buttonMorph| buttonMorph color: Color black]. "otherwise labels don't show :("
window openInWorld.
self toggleShowing: #module.
^window!
----- Method: SqueakVMProfiler>>plotGraph (in category 'graph') -----
plotGraph
sortedSamples isEmpty ifTrue: [^self].
highAddress = 0 ifTrue:
[highAddress := self highestAddress.
self updateAddressDependents].
self plotSamplesFrom: lowAddress to: highAddress.
graph fullDrawOn: Display getCanvas!
----- Method: SqueakVMProfiler>>plotSamplesFrom:to: (in category 'graph') -----
plotSamplesFrom: startAddress to: endAddress
| histSeries intSeries integral range |
graph clear.
histSeries := graph series: #histogram.
intSeries := graph alternateSeries: #integral.
intSeries color: Color magenta; type: #stepped; drawArea: Preferences vmProfilerFillInIntegral.
range := self plotSamplesFrom: startAddress to: endAddress intoHistogram: histSeries andIntegral: intSeries.
histSeries addPoint: range last @ 0.
intSeries addPoint: range last @ (integral := intSeries points isEmpty ifTrue: [0] ifFalse: [intSeries points last y]).
(integral ~= 0 and: [Preferences vmProfilerFillInIntegral]) ifTrue:
[intSeries addPoint: range last @ 0].
self assert: histSeries points isEmpty = intSeries points isEmpty.
histSeries points notEmpty ifTrue:
[self assert: histSeries points first x = intSeries points first x.
self assert: histSeries points last x = intSeries points last x].
rangeTotal := integral.
graph xAxisFormatter:
[:n|
((range first + (n asFloat - range first)) rounded asInteger printStringRadix: 16) allButFirst: 3].
graph yAxisFormatter:
[:n|
(n rounded = n
ifTrue: [n]
ifFalse:
[n >= 100
ifTrue: [n rounded]
ifFalse: [(n * 10) rounded / 10]]) printString].
graph limitMinX: range first limitMaxX: range last.
self changed: #positionedLabels; changed: #totalText!
----- Method: SqueakVMProfiler>>plotSamplesFrom:to:intoHistogram:andIntegral: (in category 'graph') -----
plotSamplesFrom: startAddress to: endAddress intoHistogram: histogramSeries andIntegral: integralSeries
"Plot the samples in the range startAddress to: endAddress, inclusive. Answer the range actually
plotted, which may be larger due to rounding when putting multiple addresses in the same bin."
| resolution sampleIndex numSamples nextSample plotter |
resolution := graph drawBounds width.
numSamples := sortedSamples size.
sampleIndex := sortedSamples findBinaryIndex: [:sample| startAddress - sample key] ifNone: [:lowIdx :highIdx| highIdx].
sampleIndex > numSamples ifTrue:
[^startAddress to: endAddress].
plotter := VMGraphPlotter new histogram: histogramSeries integral: integralSeries startAddress: startAddress.
nextSample := sortedSamples at: sampleIndex.
endAddress - startAddress + 1 > (resolution * 1.5) ifTrue:
[| binsPerPoint range sum |
binsPerPoint := (endAddress - startAddress + 1 / resolution) ceiling.
range := startAddress to: endAddress + binsPerPoint - 1 by: binsPerPoint.
range do:
[:address| | next |
next := address + binsPerPoint.
sum := 0.
[nextSample key < next] whileTrue:
[self assert: nextSample key >= address.
sum := sum + nextSample value.
(sampleIndex := sampleIndex + 1) > numSamples ifTrue:
[plotter addPlotFor: sum at: address.
^range].
nextSample := sortedSamples at: sampleIndex].
plotter addPlotFor: sum at: address].
^range].
plotter plotAsBars: true.
startAddress to: endAddress do:
[:address|
nextSample key <= address
ifTrue:
[self assert: nextSample key >= address.
plotter addPlotFor: nextSample value at: address.
(sampleIndex := sampleIndex + 1) > numSamples ifTrue:
[^startAddress to: endAddress].
nextSample := sortedSamples at: sampleIndex]
ifFalse:
[plotter addPlotFor: 0 at: address]].
^startAddress to: endAddress!
----- Method: SqueakVMProfiler>>positionedLabels (in category 'accessing') -----
positionedLabels
"Compute the set of labels to be displayed for the given address range.
Try and display no more than maxLabels labels. The result is a dictionary
of fractional position in the range to string. If there are lots of labels, try
and favour those that have samples."
| maxLabels counts types symbolsInRange positionedLabels index count range significantSymbolsInRange |
maxLabels := 50.
minSelectionIndex isZero ifTrue:
[^Dictionary new].
"count how many labels of each type there are in the range."
counts := Dictionary new.
(types := #(module objectFile publicFunction privateFunction label)) do:
[:type| counts at: type put: 0].
types := types select: [:type| symbolTypes includes: type].
symbolsInRange := symbolManager symbolsSelect: [:sym| sym address <= highAddress and: [sym limit >= lowAddress and: [(symbolTypes includes: sym type)]]].
"If there are lots of labels then choose to display only those with samples"
symbolsInRange size > (maxLabels / 2) ifTrue:
[significantSymbolsInRange := symbolsInRange select: [:s| (self samplesForSymbol: s) > 0]].
(symbolsInRange size > maxLabels
and: [significantSymbolsInRange size >= (maxLabels / 2)]) ifTrue:
[symbolsInRange := significantSymbolsInRange].
symbolsInRange do:
[:s| counts at: s type put: (counts at: s type) + 1].
"Find out what types give us at least one label but no more
than maxLabels unless necessary to have at least one."
index := 1.
count := counts at: (types at: index).
[index <= types size
and: [count + (counts at: (types at: index)) < maxLabels]] whileTrue:
[count := count + (counts at: (types at: index)).
index := index + 1].
"add labels to positionedLabels indexed by their fractional position in the range, filtering by type."
types := types copyFrom: 1 to: (index min: types size).
positionedLabels := Dictionary new: count.
range := (highAddress - lowAddress) asFloat.
symbolsInRange do:
[:s |
(types includes: s type) ifTrue:
[positionedLabels
at: ([s address - lowAddress / range]
on: ZeroDivide
do: [:ex| 0])
put: s displayText]].
^positionedLabels!
----- Method: SqueakVMProfiler>>profileColor (in category 'buttons') -----
profileColor
^self profiling ifTrue: [Color darkGray] ifFalse: [Color lightGreen]!
----- Method: SqueakVMProfiler>>profileExpression (in category 'profiling') -----
profileExpression
| expressionText logExpression block |
expressionText := expressionTextMorph text.
expressionText isEmpty ifTrue:
[^self changed: #flash].
(expressionText first = $[
and: [expressionText last = $] ]) ifFalse:
[expressionText := '[' asText, expressionText, ']' asText.
expressionTextMorph setText: expressionText].
self changed: #selectionRange with: (1 to: expressionText size).
logExpression := true. "This could be a preference but for now allows both versions to live here."
block := logExpression
ifTrue: [expressionTextMorph doIt]
ifFalse:
[Compiler
evaluate: expressionText
for: nil
notifying: (expressionTextMorph instVarNamed: 'textMorph') editor
logged: false].
block == expressionTextMorph ifTrue:
[self error: expressionTextMorph class name, '>>doit does not answer the result'].
block isBlock ifTrue:
[self spyOn: block]!
----- Method: SqueakVMProfiler>>profileExpressionButton (in category 'buttons') -----
profileExpressionButton
"Just weird!!"
^'profile:'!
----- Method: SqueakVMProfiler>>profiling (in category 'profiling') -----
profiling
^aboutToProfile or: [self statusOfVMProfile]!
----- Method: SqueakVMProfiler>>progress (in category 'selecting') -----
progress
| range |
range := history at: (historyIndex := historyIndex + 1).
lowAddress := range first.
highAddress := range last.
self updateAddressDependents.
self updateButtons.
self selectSymbolsInRange.
self plotGraph!
----- Method: SqueakVMProfiler>>selectBenchmark: (in category 'menus') -----
selectBenchmark: expressionString
expressionTextMorph setText: expressionString asText!
----- Method: SqueakVMProfiler>>selectionRange (in category 'profiling') -----
selectionRange
^expressionTextMorph
ifNotNil: [1 to: expressionTextMorph text size]
ifNil: [0 to: 0]!
----- Method: SqueakVMProfiler>>showingLabels (in category 'buttons') -----
showingLabels
^symbolTypes includes: #label!
----- Method: SqueakVMProfiler>>showingModules (in category 'buttons') -----
showingModules
^symbolTypes includes: #module!
----- Method: SqueakVMProfiler>>showingPrivateFunctions (in category 'buttons') -----
showingPrivateFunctions
^symbolTypes includes: #privateFunction!
----- Method: SqueakVMProfiler>>showingPublicFunctions (in category 'buttons') -----
showingPublicFunctions
^symbolTypes includes: #publicFunction!
----- Method: SqueakVMProfiler>>spyOn: (in category 'spying') -----
spyOn: aBlock
| r |
r := super spyOn: aBlock.
WorldState addDeferredUIMessage: [self plotGraph].
^ r
!
----- Method: SqueakVMProfiler>>startButton (in category 'buttons') -----
startButton
"just weird..."
^'start'!
----- Method: SqueakVMProfiler>>statusOfVMProfile (in category 'primitives') -----
statusOfVMProfile
<primitive: 252>
^self primitiveFailed!
----- Method: SqueakVMProfiler>>stopButton (in category 'buttons') -----
stopButton
"just weird..."
^'stop'!
----- Method: SqueakVMProfiler>>stopColor (in category 'buttons') -----
stopColor
^self profiling ifTrue: [Color red] ifFalse: [Color darkGray]!
----- Method: SqueakVMProfiler>>symbolListMenu: (in category 'menus') -----
symbolListMenu: aMenuMorph
aMenuMorph
add: 'find...' target: self selector: #findSymbol:event: argument: nil;
add: 'find module...' target: self selector: #findSymbol:event: argument: #module;
add: 'find extern...' target: self selector: #findSymbol:event: argument: #publicFunction;
add: 'find static...' target: self selector: #findSymbol:event: argument: #privateFunction;
add: 'find label...' target: self selector: #findSymbol:event: argument: #label.
sampleBuffer ifNotNil:
[aMenuMorph
addLine;
add: 'vm report' target: self selector: #vmReport: argument: #justWeird;
add: 'interpreter report' target: self selector: #interpreterReport: argument: #justWeird].
^aMenuMorph!
----- Method: SqueakVMProfiler>>symbolSelectionAt:put: (in category 'accessing') -----
symbolSelectionAt: index put: aBoolean
Transcript cr; nextPutAll: #symbolSelectionAt:; space; print: index; nextPutAll: ' put: '; print: aBoolean; flush.
minSelectionIndex := maxSelectionIndex := index.
(index between: 1 and: selections size) ifTrue:
[selections at: index put: (aBoolean ifTrue: [1] ifFalse: [0])].
1 to: minSelectionIndex - 1 do:
[:i| selections at: i put: 0].
maxSelectionIndex + 1 to: selections size do:
[:i| selections at: i put: 0].
self changed: #symbolList.
self updateAddressSelection!
----- Method: SqueakVMProfiler>>toggleClearPriorToProfile (in category 'buttons') -----
toggleClearPriorToProfile
clearPriorToProfile := clearPriorToProfile not.
self changed: #clearPriorToProfile!
----- Method: SqueakVMProfiler>>toggleForkProfile (in category 'buttons') -----
toggleForkProfile
forkProfile := forkProfile not.
self changed: #forkProfile!
----- Method: SqueakVMProfiler>>toggleGcPriorToProfile (in category 'buttons') -----
toggleGcPriorToProfile
gcPriorToProfile := gcPriorToProfile not.
self changed: #gcPriorToProfile!
----- Method: SqueakVMProfiler>>toggleListIndex: (in category 'accessing') -----
toggleListIndex: index
Transcript cr; nextPutAll: #toggleListIndex:; space; print: index; flush.
selections at: index put: ((selections at: index ifAbsent: [^self]) bitXor: 1).
self updateAddressSelection!
----- Method: SqueakVMProfiler>>toggleShowLabels (in category 'buttons') -----
toggleShowLabels
self toggleShowing: #label!
----- Method: SqueakVMProfiler>>toggleShowModules (in category 'buttons') -----
toggleShowModules
self toggleShowing: #module!
----- Method: SqueakVMProfiler>>toggleShowPrivateFunctions (in category 'buttons') -----
toggleShowPrivateFunctions
self toggleShowing: #privateFunction!
----- Method: SqueakVMProfiler>>toggleShowPublicFunctions (in category 'buttons') -----
toggleShowPublicFunctions
self toggleShowing: #publicFunction!
----- Method: SqueakVMProfiler>>toggleShowing: (in category 'buttons') -----
toggleShowing: aSymbol
(symbolTypes includes: aSymbol)
ifTrue: [symbolTypes remove: aSymbol]
ifFalse: [symbolTypes add: aSymbol].
symbolTypes isEmpty ifTrue:
[symbolTypes add: #module.
self changed: #showingModules.
aSymbol == #module ifTrue:
[^self]].
self changed: #showingModules;
changed: #showingPublicFunctions;
changed: #showingPrivateFunctions;
changed: #showingLabels.
symbolList := symbolManager symbolsWithTypes: symbolTypes.
selections := ByteArray new: symbolList size.
self selectSymbolsInRange.
self changed: #symbolList;
changed: #positionedLabels!
----- Method: SqueakVMProfiler>>totalText (in category 'accessing') -----
totalText
^(String streamContents:
[:s|
total > 0 ifTrue:
[s print: (rangeTotal * 10000 / total) rounded / 100.0;
nextPutAll: '% of';
cr].
s print: total]) asText!
----- Method: SqueakVMProfiler>>totalTextMorph:get: (in category 'opening') -----
totalTextMorph: help get: getter
| ptm |
ptm := PluggableTextMorph
on: self
text: getter accept: nil
readSelection: nil menu: nil.
ptm askBeforeDiscardingEdits: false;
setBalloonText: help;
retractableOrNot;
hideOrShowScrollBars;
setProperty: #noScrollBarPlease toValue: true;
setProperty: #noVScrollBarPlease toValue: true.
^ptm!
----- Method: SqueakVMProfiler>>trimmedExpressionText (in category 'menus') -----
trimmedExpressionText
| expression |
^((expression := expressionTextMorph text asString) notEmpty
and: [expression first = $[
and: [expression last = $] ]])
ifTrue: [expression copyFrom: 2 to: expression size - 1]
ifFalse: [expression]!
----- Method: SqueakVMProfiler>>updateAddressDependents (in category 'accessing') -----
updateAddressDependents
self changed: #lowAddressText; changed: #highAddressText; changed: #symbolIndex.
self dependents do:
[:dep|
(dep class == PluggableTextMorph
and: [dep getTextSelector == #highAddressText]) ifTrue:
[(dep instVarNamed: 'textMorph') editor setAlignment: #rightFlush]]!
----- Method: SqueakVMProfiler>>updateAddressSelection (in category 'accessing') -----
updateAddressSelection
| min max |
1 to: selections size do:
[:i|
(selections at: i) > 0 ifTrue:
[min ifNil: [min :=i].
max := i]].
min
ifNil: [lowAddress := 0.
highAddress := self highestAddress.
minSelectionIndex := maxSelectionIndex := 0]
ifNotNil:
[minSelectionIndex := min. maxSelectionIndex := max.
minSelectionIndex + 1 to: maxSelectionIndex - 1 do:
[:i| selections at: i put: 1].
lowAddress := (symbolList at: minSelectionIndex) address.
highAddress := (symbolList at: maxSelectionIndex) limit].
self updateAddressDependents!
----- Method: SqueakVMProfiler>>updateButtons (in category 'buttons') -----
updateButtons
WorldState addDeferredUIMessage:
[self changed: #profileColor; changed: #clearColor; changed: #stopColor.
self changed: #profiling; changed: #notProfiling; changed: #notProfilingAndData.
self changed: #hasHistoryColor; changed: #hasFutureColor.
self changed: #hasHistory; changed: #hasFuture]!
----- Method: VMProfiler 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.'!
----- Method: VMProfiler class>>canBenchmark: (in category 'class initialization') -----
canBenchmark: aByteString
CannedBenchmarkStrings addLast: aByteString!
----- Method: VMProfiler class>>fixTabs (in category 'class initialization') -----
fixTabs
"Make sure the DefaultTabsArray and DefaultMarginTabsArray are adequately sized for modern displays."
| defaultTab tempArray width |
(Smalltalk bindingOf: #TextConstants) ifNil: [^self].
width := 2000.
(TextConstants at: #DefaultTabsArray) last < width ifTrue:
[defaultTab := TextConstants at: #DefaultTab.
tempArray := Array new: 2000 // defaultTab.
1 to: tempArray size do:
[:i | tempArray at: i put: defaultTab * i].
TextConstants at: #defaultTabsArray put: tempArray.
tempArray := Array new: (width // defaultTab) // 2.
1 to: tempArray size do:
[:i | tempArray at: i put: (Array with: (defaultTab*i) with: (defaultTab*i))].
TextConstants at: #DefaultMarginTabsArray put: tempArray]!
----- Method: VMProfiler class>>headlessSpyOn:reportOn: (in category 'as yet unclassified') -----
headlessSpyOn: aBlock reportOn: aStream
"initialize the profiler version (squeak or pharo) and profile headless, writing the results on a given stream"
(VMProfiler new) version new
headlessSpyOn: aBlock;
report: aStream.
!
----- Method: VMProfiler class>>initialize (in category 'class initialization') -----
initialize
CannedBenchmarkStrings := OrderedCollection new.
"(TheWorldMenu respondsTo: #registerOpenCommand:) ifTrue:
[TheWorldMenu registerOpenCommand: {'VM Profiler'. {self. #open}. 'A VM profiler'}].
Preferences
addBooleanPreference: #vmProfilerFillInIntegral
category: #vmProfiler
default: false
balloonHelp: 'If enabled, the profiler will fill in the area under the integral.'.
self fixTabs"!
----- Method: VMProfiler class>>reportGCStats:upTime:on: (in category 'reports') -----
reportGCStats: gcStatsArray upTime: elapsedMilliseconds on: str
| oldSpaceEnd youngSpaceEnd memoryEnd fullGCs fullGCTime incrGCs incrGCTime tenureCount rootOverflows |
gcStatsArray ifNil: [^self].
oldSpaceEnd := gcStatsArray at: 2. "a.k.a. oldSpace size on Spur"
fullGCs := gcStatsArray at: 7.
fullGCTime := gcStatsArray at: 8.
incrGCs := gcStatsArray at: 9.
incrGCTime := gcStatsArray at: 10.
tenureCount := gcStatsArray at: 11.
rootOverflows := gcStatsArray at: 22.
str cr.
str nextPutAll: '**Memory**'; cr.
str nextPutAll: ' old ';
nextPutAll: oldSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr.
self amOnSpur
ifTrue:
[(gcStatsArray at: 54) ifNotNil:
[:freeSpace|
str nextPutAll: ' free ';
nextPutAll: freeSpace asStringWithCommasSigned; nextPutAll: ' bytes'; cr]]
ifFalse:
[youngSpaceEnd := gcStatsArray at: 1.
memoryEnd := gcStatsArray at: 3.
str nextPutAll: ' young ';
nextPutAll: (youngSpaceEnd - oldSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr.
str nextPutAll: ' used ';
nextPutAll: youngSpaceEnd asStringWithCommasSigned; nextPutAll: ' bytes'; cr.
str nextPutAll: ' free ';
nextPutAll: (memoryEnd - youngSpaceEnd) asStringWithCommasSigned; nextPutAll: ' bytes'; cr].
str cr.
str nextPutAll: '**GCs**'; cr.
str nextPutAll: ' full ';
print: fullGCs; nextPutAll: ' totalling '; nextPutAll: fullGCTime asStringWithCommas; nextPutAll: 'ms (';
print: ((fullGCTime / elapsedMilliseconds * 100) rounded);
nextPutAll: '% elapsed time)'.
fullGCs = 0 ifFalse:
[str nextPutAll: ', avg '; print: (fullGCTime / fullGCs roundTo: 0.1); nextPutAll: 'ms'].
str cr.
str nextPutAll: (self amOnSpur ifTrue: [' scavenges '] ifFalse: [' incr ']);
print: incrGCs; nextPutAll: ' totalling '; nextPutAll: incrGCTime asStringWithCommas; nextPutAll: 'ms (';
print: ((incrGCTime / elapsedMilliseconds * 100) roundTo: 0.1);
nextPutAll: '% elapsed time)'.
incrGCs = 0 ifFalse:
[str nextPutAll:', avg '; print: (incrGCTime / incrGCs roundTo: 0.01); nextPutAll: 'ms'].
str cr.
str nextPutAll: ' tenures ';
nextPutAll: tenureCount asStringWithCommas.
tenureCount = 0 ifFalse:
[str nextPutAll: ' (avg '; print: (incrGCs / tenureCount) asInteger; nextPutAll: ' GCs/tenure)'].
str cr.
str nextPutAll: ' root table ';
nextPutAll: rootOverflows asStringWithCommas; nextPutAll:' overflows'.
str cr.
(gcStatsArray size >= 63 and: [(gcStatsArray at: 63) isInteger]) ifTrue:
[| numCompactions compactionMsecs |
str cr; nextPutAll: '**Compiled Code Compactions**'; cr.
numCompactions := gcStatsArray at: 62.
compactionMsecs := gcStatsArray at: 63.
str tab;
print: numCompactions; nextPutAll: ' totalling ';
nextPutAll: compactionMsecs asStringWithCommas; nextPutAll: 'ms (';
print: ((compactionMsecs / elapsedMilliseconds * 100) rounded);
nextPutAll: '% elapsed time)'.
numCompactions = 0 ifFalse:
[str nextPutAll: ', avg '; print: (compactionMsecs / numCompactions roundTo: 0.1); nextPutAll: 'ms'].
str cr].
gcStatsArray size >= 61 ifTrue:
[str cr; nextPutAll: '**Events**'; cr.
(56 to: 61)
with: #('Process switches' 'ioProcessEvents calls' 'Interrupt checks' 'Event checks' 'Stack overflows' 'Stack page divorces')
do: [:index :eventName| | value n |
value := gcStatsArray at: index.
n := 22 - eventName size // 4 + 1.
str nextPutAll: eventName; tab: n; print: value; nextPutAll: ' (';
print: (value * 1000 / elapsedMilliseconds) rounded; nextPutAll: ' per second)'; cr]]!
----- Method: VMProfiler class>>spyOn: (in category 'spying') -----
spyOn: aBlock
(VMProfiler new) version default
spyOn: aBlock.
!
----- Method: VMProfiler class>>unload (in category 'class initialization') -----
unload
(TheWorldMenu respondsTo: #unregisterOpenCommandWithReceiver:) ifTrue:
[TheWorldMenu unregisterOpenCommandWithReceiver: self].
TheWorldMenu unregisterOpenCommand: 'VM Profiler'!
----- Method: VMProfiler>>clearHistory (in category 'initialization') -----
clearHistory
history := OrderedCollection new.
historyIndex := 0!
----- Method: VMProfiler>>clearProfile (in category 'profiling') -----
clearProfile
self stopVMProfile.
self clearVMProfile.
self stopVMProfile.
self initializeSamples.
elapsedTime := 0.
elapsedStats := nil.
self clearHistory.
!
----- Method: VMProfiler>>clearVMProfile (in category 'primitives') -----
clearVMProfile
"Clear the VM profile sample buffer."
<primitive: 250>
^self primitiveFailed!
----- Method: VMProfiler>>computeCogCodeModule (in category 'Cog compiled code') -----
computeCogCodeModule
cogCodeConstituents ifNil: [^self].
symbolManager computeCogCodeModule: cogCodeConstituents.
self changed: #symbolList
"Compute average cog method size:
(| cogCodeConstituents i1 i2 |
cogCodeConstituents := VMProfiler basicNew primitiveCollectCogCodeConstituents.
i1 := cogCodeConstituents indexOf: 'methodZoneBase'.
i2 := cogCodeConstituents indexOf: 'CCFree'.
(cogCodeConstituents at: i2 + 1) - (cogCodeConstituents at: i1 + 1) / (i2 - i1 / 2.0))"!
----- Method: VMProfiler>>computeHistograms: (in category 'profiling') -----
computeHistograms: numSamples
sampleBuffer ifNil:
[sampleBuffer := Bitmap new: self profileSize].
self getVMProfileSamplesInto: sampleBuffer.
Cursor wait showWhile:
[1 to: numSamples do:
[:i|
sampleBag add: (sampleBuffer at: i)].
sortedSamples := sampleBag sortedElements].
total := total + numSamples!
----- Method: VMProfiler>>computeSortedSymbols (in category 'sorting') -----
computeSortedSymbols
sortedSymbols := cogCodeConstituents
ifNil: [self sortSymbols: symbolManager modules]
ifNotNil:
[self sortedSymbolsBeforeCogCode,
(self sortSymbols: {symbolManager cogModule}),
self sortedSymbolsAfterCogCode]!
----- Method: VMProfiler>>computeStats: (in category 'profiling') -----
computeStats: stopStats
elapsedStats ifNil: [elapsedStats := Array new: stopStats size withAll: 0].
startStats ifNotNil:
[(#(1 2 3 7 8 9 10 11 22 46 47 56 57 58 59 60 61 62 63) select: [:i| i <= elapsedStats size]) do:
[:i|
(stopStats at: i) isNumber ifTrue:
[elapsedStats at: i put: (stopStats at: i) - (startStats at: i)]]]!
----- Method: VMProfiler>>createParagraph (in category 'as yet unclassified') -----
createParagraph
self subclassResponsibility !
----- Method: VMProfiler>>getVMParameters (in category 'as yet unclassified') -----
getVMParameters
self subclassResponsibility !
----- Method: VMProfiler>>getVMProfileSamplesInto: (in category 'primitives') -----
getVMProfileSamplesInto: sampleBuffer
"Stop profiling the virtual machine and if the argument is a
Bitmap of the right size, copy the profile data into it. Otherwise fail."
<primitive: 252>
^self primitiveFailed!
----- Method: VMProfiler>>headlessSpyOn: (in category 'spying') -----
headlessSpyOn: aBlock
| blockToProfile r |
blockToProfile := forkProfile
ifTrue:
[| sem fr |
sem := Semaphore new.
[[fr := aBlock value. sem signal] fork.
sem wait.
fr]]
ifFalse: [aBlock].
[self selectBenchmark: aBlock sourceString]
on: Error
do: [:ex|].
self startProfiling.
r := blockToProfile ensure: [self stopProfiling].
^r
!
----- Method: VMProfiler>>initialExtent (in category 'opening') -----
initialExtent
^768 at 768 min: RealEstateAgent maximumUsableArea extent!
----- Method: VMProfiler>>initialize (in category 'initialization') -----
initialize
self initializeSamples.
self initializeVersion.
self initializeSymbols.
self clearHistory.
symbolsMode := #byAddress.
symbolTypes := IdentitySet new.
selections := ByteArray new.
highAddress := lowAddress := minSelectionIndex := maxSelectionIndex := 0.
self toggleShowing: #module.
aboutToProfile := false.
total := rangeTotal := startTime := elapsedTime := 0.
gcPriorToProfile := clearPriorToProfile := true.
forkProfile := false!
----- Method: VMProfiler>>initializeSamples (in category 'initialization') -----
initializeSamples
sampleBag := Bag new. sortedSamples := sampleBag sortedElements.
total := 0.!
----- Method: VMProfiler>>initializeSymbols (in category 'initialization') -----
initializeSymbols
Smalltalk platformName
caseOf: {
['Mac OS'] -> [Cursor wait showWhile:
[ symbolManager := VMProfilerMacSymbolsManager using: fileSystem ]].
['unix'] -> [Cursor wait showWhile:
[symbolManager := VMProfilerLinuxSymbolsManager using: fileSystem]] }
otherwise: [self error: 'not yet supported on ', Smalltalk platformName]!
----- Method: VMProfiler>>initializeVersion (in category 'initialization') -----
initializeVersion
('Pharo*' match: Smalltalk version) ifTrue: [ version := PharoVMProfiler.
fileSystem := PharoVMFileSystem new].
('Squeak*' match: Smalltalk version) ifTrue: [ version := SqueakVMProfiler.
fileSystem := SqueakVMFileSystem new].
!
----- Method: VMProfiler>>interpReport: (in category 'reports') -----
interpReport: s
| totals samplesInInterp |
totals := Dictionary new.
samplesInInterp := 0.
Cursor execute showWhile:
[| interp labels|
interp := (symbolManager symbolsInModule: symbolManager vmModule) detect:
[:sym| sym name endsWith: 'interpret'].
labels := (symbolManager symbolsInModule: symbolManager vmModule) select:
[:sym|
sym type == #label
and: [sym address between: interp address and: interp limit]].
symbolList := {interp}, labels.
symbolList withIndexDo:
[:sym :index| | samples |
samples := self samplesForRange: sym address
to: (index < symbolList size
ifTrue: [(symbolList at: index + 1) address]
ifFalse: [interp limit]).
samples > 0 ifTrue:
[totals at: sym put: samples.
samplesInInterp := samplesInInterp + samples]]].
self putReportPreambleOn: s.
s print: samplesInInterp; nextPutAll: ' samples in the Interpreter'; tab; nextPut: $(;
print: total; nextPutAll: ' samples in the entire program) '.
self printPercentage: samplesInInterp total: total on: s.
s nextPutAll: ' of total'; cr; cr.
totals isEmpty ifFalse:
[self printSymbolTotals: totals labelled: 'interpret' on: s sumTotal: samplesInInterp].
self class reportGCStats: elapsedStats upTime: elapsedTime on: s!
----- Method: VMProfiler>>interpreterReport: (in category 'reports') -----
interpreterReport: justWeird
UIManager default
edit: (String streamContents: [:s| self interpReport: s])
label: 'Interpreter Labels by Cost'!
----- Method: VMProfiler>>listEntryForIndex: (in category 'accessing') -----
listEntryForIndex: index
^(symbolList at: index ifAbsent: [^nil]) displayText!
----- Method: VMProfiler>>longestWidthIn: (in category 'reports') -----
longestWidthIn: aCollectionOfAssociations
^aCollectionOfAssociations inject: 0 into:
[:len :assoc|
len max: (self widthInDefaultFontOf: (assoc key isString
ifTrue: [assoc key]
ifFalse: [assoc key name]))]!
----- Method: VMProfiler>>primitiveCollectCogCodeConstituents (in category 'primitives') -----
primitiveCollectCogCodeConstituents
"Answer the contents of the code zone as an array of pair-wise element, address
in ascending address order. Answer a string for a runtime routine or abstract label
(beginning, end, etc), a CompiledMethod for a cog machine-code method,
or a selector (presumably a Symbol) for a cog machine-code open or closed PIC.
Fail if this isn't a Cog VM or if out of memory. If this isn't a Cog VM answer nil."
<primitive: 253 error: ec>
^ec ifNotNil: [self primitiveFailed]
"self basicNew primitiveCollectCogCodeConstituents"!
----- Method: VMProfiler>>primitiveControlVMProfile:size: (in category 'primitives') -----
primitiveControlVMProfile: startStopBar size: bufferSizeOrNil
"Control the VM statistical profile pc sampling system.
The first argument must be a boolean which causes the system to start or stop.
The second argument can be nil or is the number of samples to make space for.
Answer the current number of samples in the buffer."
<primitive: 251>
^self primitiveFailed!
----- Method: VMProfiler>>printPercentage:total:on: (in category 'menus') -----
printPercentage: value total: total on: aStream
"Print percentage as NN.FF% (or 100.0%) on aStream"
| rounded percentage |
percentage := (rounded := (value * 10000 / total) rounded) / 100.0.
percentage < 10 ifTrue:
[aStream space; space].
aStream print: percentage.
(rounded \\ 10 = 0 and: [rounded ~= 10000]) ifTrue:
[aStream nextPut: $0].
aStream nextPut: $%!
----- Method: VMProfiler>>printSymbolTotals:labelled:on:sumTotal: (in category 'reports') -----
printSymbolTotals: totals labelled: label on: aStream sumTotal: sumTotal
"Print sorted totals for all symbols with a total greater than 0.01% of the grand total."
| substantial insubstantial cut cumulative heading percentageWidth compositionWidth tabWidth labelWidthCut labelledInFull |
cut := total / 10000.0.
substantial := totals associations select: [:assoc| assoc value > cut].
labelWidthCut := total / 1000.0.
labelledInFull := totals associations select: [:assoc| assoc value > labelWidthCut].
insubstantial := totals associations
inject: 0
into: [:sum :assoc|
(assoc value <= cut ifTrue: [assoc value] ifFalse: [0]) + sum].
substantial := substantial asSortedCollection:
[:a1 :a2|
a1 value > a2 value
or: [a1 value = a2 value and: [a1 name < a2 name]]].
insubstantial > 0 ifTrue:
[substantial := substantial asArray, {'...others...'->insubstantial}].
cumulative := 0.
heading := '% of ', label, ' (% of total)'.
tabWidth := self widthInDefaultFontOf: (String with: Character tab).
percentageWidth := self widthInDefaultFontOf: '99.99% (99.99%) '.
compositionWidth := (self longestWidthIn: labelledInFull) + tabWidth
max: (self widthInDefaultFontOf: heading) + tabWidth - percentageWidth.
self put: heading paddedTo: compositionWidth + percentageWidth tabWidth: tabWidth on: aStream.
aStream nextPutAll: '(samples) (cumulative)'; cr.
substantial do:
[:assoc|
self printPercentage: assoc value total: sumTotal on: aStream.
aStream space; space; space; space; nextPut: $(.
self printPercentage: assoc value total: total on: aStream.
aStream nextPut: $); tab.
self put: (assoc key isString ifTrue: [assoc key] ifFalse: [assoc key name])
paddedTo: compositionWidth
tabWidth: tabWidth
on: aStream.
aStream nextPut: $(; print: assoc value; nextPut: $); tab: (assoc value < 100 ifTrue: [2] ifFalse: [1]); nextPut: $(.
cumulative := cumulative + assoc value.
self printPercentage: cumulative total: sumTotal on: aStream.
aStream nextPut: $); cr].
aStream cr; cr!
----- Method: VMProfiler>>profileSize (in category 'profiling') -----
profileSize
"Answer the number of pc samples to allocate space for in the VM.
This corresponds to the maximum time the system can collect samples.
Since the VM manages the sample buffer as a ring buffer the VM
answers the last profileSize samples.
256 * 1024 / (1000000 / 666.0) = 174.6 seconds = 2.9 minutes"
^256 * 1024!
----- Method: VMProfiler>>put:paddedTo:tabWidth:on: (in category 'reports') -----
put: aString paddedTo: compositionWidth tabWidth: tabWidth on: aStream
| fittedString size width |
fittedString := aString.
size := fittedString size.
[(width := self widthInDefaultFontOf: fittedString) > compositionWidth] whileTrue:
[size := size - 2.
fittedString := aString contractTo: size].
aStream
nextPutAll: fittedString;
tab: compositionWidth - width + (width \\ tabWidth) // tabWidth!
----- 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 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]!
----- Method: VMProfiler>>regress (in category 'selecting') -----
regress
| range |
range := history at: historyIndex.
range = (lowAddress to: highAddress)
ifTrue:
[(historyIndex := historyIndex - 1) > 0 ifTrue:
[range := history at: historyIndex]]
ifFalse:
[history addLast: (lowAddress to: highAddress)].
lowAddress := range first.
highAddress := range last.
self updateAddressDependents.
self updateButtons.
self selectSymbolsInRange.
self plotGraph!
----- Method: VMProfiler>>report: (in category 'reports') -----
report: s
self totalsDo:
[:vmTotals :cogTotals :nonVMTotals
:samplesInVM :samplesInCog :samplesInNonVMModules :samplesInNonVM |
"self putReportPreambleOn: s."
s print: samplesInVM + samplesInCog; nextPutAll: ' samples in the VM'; tab; nextPut: $(;
print: total; nextPutAll: ' samples in the entire program) '.
self printPercentage: samplesInVM + samplesInCog total: total on: s.
s nextPutAll: ' of total'; cr; cr.
cogTotals isEmpty ifFalse:
[s print: samplesInCog; nextPutAll: ' samples in generated vm code '.
self printPercentage: samplesInCog total: samplesInVM + samplesInCog on: s.
s nextPutAll: ' of entire vm ('.
self printPercentage: samplesInCog total: total on: s.
s nextPutAll: ' of total)'; cr.
s print: samplesInVM; nextPutAll: ' samples in vanilla vm code '.
self printPercentage: samplesInVM total: samplesInVM + samplesInCog on: s.
s nextPutAll: ' of entire vm ('.
self printPercentage: samplesInVM total: total on: s.
s nextPutAll: ' of total)'; cr; cr.
self printSymbolTotals: cogTotals labelled: 'generated vm code' on: s sumTotal: samplesInCog].
vmTotals isEmpty ifFalse:
[self printSymbolTotals: vmTotals labelled: 'vanilla vm code' on: s sumTotal: samplesInVM].
(samplesInNonVM * 100 >= total
and: [nonVMTotals notEmpty]) ifTrue:
[s print: samplesInNonVM; nextPutAll: ' samples in the rest '.
self printPercentage: samplesInNonVM total: total on: s.
s nextPutAll: ' of total'; cr; cr.
self printSymbolTotals: nonVMTotals labelled: 'rest' on: s sumTotal: samplesInNonVM].
self class reportGCStats: elapsedStats upTime: elapsedTime on: s]!
----- Method: VMProfiler>>samplesForRange:to: (in category 'accessing') -----
samplesForRange: address to: limit
| numSamples sampleIndex size nextSample |
numSamples := 0.
sampleIndex := sortedSamples findBinaryIndex: [:sample| address - sample key] ifNone: [:lowIdx :highIdx| highIdx].
size := sortedSamples size.
[sampleIndex <= size
and: [(nextSample := sortedSamples at: sampleIndex) key < limit]] whileTrue:
[numSamples := numSamples + nextSample value.
sampleIndex := sampleIndex + 1].
^numSamples!
----- Method: VMProfiler>>samplesForSymbol: (in category 'accessing') -----
samplesForSymbol: sym
^self samplesForRange: sym address to: sym limit!
----- Method: VMProfiler>>selectProportionFrom:to: (in category 'selecting') -----
selectProportionFrom: low to: high
| range |
self addToHistory.
range := highAddress - lowAddress.
highAddress := lowAddress + (range * high) rounded.
lowAddress := lowAddress + (range * low) rounded.
self selectSymbolsInRange.
self updateAddressDependents.
self updateButtons.
self plotGraph!
----- Method: VMProfiler>>selectSymbolsInRange (in category 'selecting') -----
selectSymbolsInRange
minSelectionIndex := maxSelectionIndex := 0.
1 to: (selections size min: symbolList size) do:
[:i| | symbol |
symbol := symbolList at: i.
selections at: i put: ((symbol limit notNil "guard against lazy initialization"
and: [symbol limit > lowAddress
and: [symbol address <= highAddress]])
ifTrue: [minSelectionIndex = 0 ifTrue: [minSelectionIndex := i].
maxSelectionIndex := i.
1]
ifFalse: [0])].
self changed: #allSelections.
self changed: #symbolIndex!
----- Method: VMProfiler>>sortSymbols: (in category 'sorting') -----
sortSymbols: modules
"Answer an Array of all the symbols in each of modules, which is assumed to be sorted."
^Array streamContents:
[:s| | prev |
modules do:
[:m|
prev
ifNil: [prev := m]
ifNotNil: [m address > prev address ifFalse: [self error: 'modules not sorted']].
s nextPut: m;
nextPutAll: ((symbolManager symbolsInModule: m) sorted:
[:s1 :s2|
s1 address = s2 address
ifTrue: [s1 importance > s2 importance]
ifFalse: [s1 address < s2 address]])]]!
----- Method: VMProfiler>>sortedSymbolsAfterCogCode (in category 'sorting') -----
sortedSymbolsAfterCogCode
^sortedSymbolsAfterCogCode ifNil:
[sortedSymbolsAfterCogCode := self sortSymbols: (symbolManager modules select: [:m| m address > cogCodeConstituents last])]!
----- Method: VMProfiler>>sortedSymbolsBeforeCogCode (in category 'sorting') -----
sortedSymbolsBeforeCogCode
^sortedSymbolsBeforeCogCode ifNil:
[sortedSymbolsBeforeCogCode := self sortSymbols: (symbolManager modules select: [:m| m address < cogCodeConstituents second])]!
----- Method: VMProfiler>>spyOn: (in category 'spying') -----
spyOn: aBlock
^ self headlessSpyOn: aBlock
!
----- Method: VMProfiler>>startProfiling (in category 'profiling') -----
startProfiling
"still UI-dependent"
"Use aboutToProfile to allow us to change the button colors without including the change in the profile."
aboutToProfile := true.
self clearHistory.
"self updateButtons."
World doOneCycleNow.
clearPriorToProfile ifTrue: [self clearProfile].
gcPriorToProfile ifTrue: [Smalltalk garbageCollect].
startStats := self getVMParameters.
startTime := Time millisecondClockValue.
self startVMProfile.
aboutToProfile := false!
----- Method: VMProfiler>>startVMProfile (in category 'primitives') -----
startVMProfile
"Start profiling the virtual machine."
self primitiveControlVMProfile: true size: self profileSize!
----- Method: VMProfiler>>stopProfiling (in category 'profiling') -----
stopProfiling
"still UI-dependent"
| numSamples now vmParameters |
numSamples := self stopVMProfile.
now := Time millisecondClockValue.
vmParameters := self getVMParameters.
cogCodeConstituents := self primitiveCollectCogCodeConstituents.
elapsedTime := now - startTime + elapsedTime.
self computeStats: vmParameters.
self computeHistograms: numSamples.
self computeCogCodeModule.
"self computeSortedSymbols." "makes the profiling crash"
self clearHistory.
"self updateButtons"!
----- Method: VMProfiler>>stopVMProfile (in category 'primitives') -----
stopVMProfile
"Stop profiling the virtual machine."
^self primitiveControlVMProfile: false size: self profileSize!
----- Method: VMProfiler>>symbolIndex (in category 'accessing') -----
symbolIndex
"Answer the first index in the last contiguous range of selections."
| index |
minSelectionIndex = 0 ifTrue: [^0].
index := maxSelectionIndex.
[index > 1 and: [(selections at: index - 1) ~= 0]] whileTrue:
[index := index - 1].
^index!
----- Method: VMProfiler>>symbolList (in category 'accessing') -----
symbolList
^symbolList!
----- Method: VMProfiler>>symbolSelectionAt: (in category 'accessing') -----
symbolSelectionAt: index
^(selections at: index ifAbsent: [0]) ~= 0!
----- Method: VMProfiler>>toggleShowing: (in category 'buttons') -----
toggleShowing: aSymbol
(symbolTypes includes: aSymbol)
ifTrue: [symbolTypes remove: aSymbol]
ifFalse: [symbolTypes add: aSymbol].
symbolTypes isEmpty ifTrue:
[symbolTypes add: #module.
self changed: #showingModules.
aSymbol == #module ifTrue:
[^self]].
self changed: #showingModules;
changed: #showingPublicFunctions;
changed: #showingPrivateFunctions;
changed: #showingLabels.
symbolList := symbolManager symbolsWithTypes: symbolTypes.
selections := ByteArray new: symbolList size.
self selectSymbolsInRange.
self changed: #symbolList;
changed: #positionedLabels!
----- Method: VMProfiler>>totalsDo: (in category 'reports') -----
totalsDo: septuaryBlock
"Evaluate aBlock with
a Dictionary of symbol -> total for the functions in the VM (excluding generated code)
a Dictionary of symbol -> total for the generated code in the VM
a Dictionary of symbol -> total for the functions in other code
total number of samples in functions in the VM (excluding generated code)
total number of samples in generated code in the VM
total number of samples in generated code in the VM
total number of samples in functions in other code
total number of samples not in VM or VM-generated code (incudes code not in any function)"
| vmTotals cogTotals nonVMTotals
samplesInVM samplesInCog samplesInNonVMModules samplesInNonVM |
vmTotals := Dictionary new.
cogTotals := Dictionary new.
nonVMTotals := Dictionary new.
samplesInVM := samplesInCog := samplesInNonVMModules := 0.
(symbolManager symbolsInModule: symbolManager vmModule) do:
[:sym| | samples |
((#(publicFunction privateFunction) includes: sym type)
and: [(samples := self samplesForSymbol: sym) > 0]) ifTrue:
[vmTotals at: sym put: samples.
samplesInVM := samplesInVM + samples]].
(symbolManager symbolsInModule: symbolManager cogModule) do:
[:sym| | samples |
((#(publicFunction privateFunction) includes: sym type)
and: [(samples := self samplesForSymbol: sym) > 0]) ifTrue:
[cogTotals at: sym put: samples.
samplesInCog := samplesInCog + samples]].
((symbolManager modules
copyWithout: symbolManager vmModule)
copyWithout: symbolManager cogModule) do:
[:module|
(symbolManager symbolsInModule: module) do:
[:sym| | samples |
((#(publicFunction privateFunction) includes: sym type)
and: [(samples := self samplesForSymbol: sym) > 0]) ifTrue:
[nonVMTotals at: sym put: samples.
samplesInNonVMModules := samplesInNonVMModules + samples]]].
samplesInNonVM := total - samplesInVM - samplesInCog.
nonVMTotals
at: 'Samples Not In Any Function'
put: samplesInNonVM - samplesInNonVMModules.
septuaryBlock valueWithArguments:
{vmTotals.
cogTotals.
nonVMTotals.
samplesInVM.
samplesInCog.
samplesInNonVMModules.
samplesInNonVM}!
----- Method: VMProfiler>>version (in category 'accessing') -----
version
^ version !
----- Method: VMProfiler>>vmReport: (in category 'reports') -----
vmReport: justWeird
UIManager default
edit: (String streamContents: [:s| self report: s])
label: 'VM Functions by Cost'!
----- Method: VMProfiler>>widthInDefaultFontOf: (in category 'reports') -----
widthInDefaultFontOf: aString
^(self createParagraph
compose: aString asText
style: TextStyle default
from: 1
in: Display boundingBox;
adjustRightX)
extent x!
Morph subclass: #VMProfileGraphLabelMorph
instanceVariableNames: 'positionedLabels font getLabelsSelector model'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: VMProfileGraphLabelMorph 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.'!
----- Method: VMProfileGraphLabelMorph class>>model:font:getLabels: (in category 'instance creation') -----
model: anObject font: aFont getLabels: aSelector
^self new
model: anObject;
font: aFont;
getLabelsSelector: aSelector;
yourself!
----- Method: VMProfileGraphLabelMorph>>changed (in category 'updating') -----
changed
positionedLabels := model perform: getLabelsSelector.
super changed!
----- Method: VMProfileGraphLabelMorph>>drawClippedOn: (in category 'drawing') -----
drawClippedOn: clippedCanvas
"Display the labels at their relative positions sloping down at 45 degrees.
Draw a label every font height pixels along to avoid a mess when there are lots of labels."
| labelForm lfc rotatedLabelForm rlfc warp degSin degCos side rect pts minDelta lastX margin range rotationOffset xs |
labelForm := Form extent: self height * 2 @ font height depth: 4.
rotatedLabelForm := Form extent: self height asPoint depth: 4.
lfc := labelForm getCanvas.
rlfc := rotatedLabelForm getCanvas.
warp := (WarpBlt current toForm: rotatedLabelForm)
sourceForm: labelForm;
colorMap: (labelForm colormapIfNeededFor: rotatedLabelForm);
cellSize: 2 "smooothing"; "installs a new colormap if cellSize > 1"
combinationRule: Form paint.
degSin := 45 degreeSin.
degCos := 45 degreeCos.
"See Form>>rotateBy:magnify:smoothing:"
side := labelForm extent r.
rect := (0 at 0 extent: side at side) align: (side / 2) asPoint with: labelForm extent / 2.
pts := rect innerCorners collect:
[:pt | | p |
p := pt - rect center.
((labelForm width / 2.0) + (p x asFloat*degCos) + (p y asFloat*degSin)) @
((labelForm height / 2.0) - (p x asFloat*degSin) + (p y asFloat*degCos))].
minDelta := font height / 1.5.
lastX := font height negated.
margin := model graphMargin.
range := self width - margin - margin.
rotationOffset := (labelForm height / 2 * 2 sqrt) ceiling.
(xs := positionedLabels keys asSortedCollection) withIndexDo:
[:fractionalX :index| | x |
x := (fractionalX * range) rounded.
(lastX + minDelta <= x
or: [index < xs size
and: [lastX + minDelta + minDelta <= ((xs at: index + 1) * range)]]) ifTrue:
[lfc
fillColor: Color black;
drawString: (positionedLabels at: fractionalX) at: 0 at 0 font: font color: Color white.
rlfc
fillColor: Color black.
warp copyQuad: pts toRect: rotatedLabelForm boundingBox.
clippedCanvas
image: rotatedLabelForm
at: self bounds origin + ((fractionalX * range max: lastX + minDelta) floor + margin - rotationOffset at 0)
sourceRect: rotatedLabelForm boundingBox
rule: Form erase.
true ifTrue:
[| box |
box := (self bounds origin + ((fractionalX * range) floor + margin at 0)) extent: 1 at 6.
Display fill: box rule: Form over fillColor: Color gray].
lastX := x]]!
----- Method: VMProfileGraphLabelMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
super drawOn: aCanvas.
aCanvas
clipBy: self bounds
during:
[:clippedCanvas|
self drawClippedOn: clippedCanvas]!
----- Method: VMProfileGraphLabelMorph>>font (in category 'accessing') -----
font
"Answer the value of font"
^ font!
----- Method: VMProfileGraphLabelMorph>>font: (in category 'accessing') -----
font: anObject
"Set the value of font"
font := anObject!
----- Method: VMProfileGraphLabelMorph>>getLabelsSelector (in category 'accessing') -----
getLabelsSelector
"Answer the value of getLabelsSelector"
^ getLabelsSelector!
----- Method: VMProfileGraphLabelMorph>>getLabelsSelector: (in category 'accessing') -----
getLabelsSelector: anObject
"Set the value of getLabelsSelector"
getLabelsSelector := anObject!
----- Method: VMProfileGraphLabelMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
color := Color lightBlue lighter lighter.
positionedLabels := Dictionary new.
font := TextStyle default defaultFont.
getLabelsSelector := #positionedLabels!
----- Method: VMProfileGraphLabelMorph>>model (in category 'accessing') -----
model
"Answer the value of model"
^ model!
----- Method: VMProfileGraphLabelMorph>>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!
----- Method: VMProfileGraphLabelMorph>>update: (in category 'updating') -----
update: aParameter
aParameter == getLabelsSelector ifTrue:
[self changed]!
RectangleMorph subclass: #AxesMorph
instanceVariableNames: 'form limitMaxX limitMinX limitMaxY limitMinY title xmax xmid xmin ymax ymid ymin xAxisFormatter yAxisFormatter margin grid drawCotas'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!AxesMorph commentStamp: 'jcg 8/29/2003 23:01' prior: 0!
I am responsible for drawing a pair of axes, a grid, and various labels. I am not responsible for the display of any data, or for handling user input in any special way.!
----- Method: AxesMorph>>baseColor (in category 'accessing') -----
baseColor
"Answer the base color to calculate other colors from"
| baseColor current |
baseColor := self color.
current := self.
[current notNil & (baseColor = Color transparent)]
whileTrue: [""
baseColor := current color.
current := current owner].
^ baseColor!
----- Method: AxesMorph>>changed (in category 'change reporting') -----
changed
super changed.
form := nil.!
----- Method: AxesMorph>>color: (in category 'accessing') -----
color: aColor
super color: aColor.
self updateCotas!
----- Method: AxesMorph>>cotaColor (in category 'drawing') -----
cotaColor
| baseColor lighter darker |
baseColor := self baseColor asNontranslucentColor.
baseColor = Color white
ifTrue: [^ Color black].
""
lighter := baseColor muchLighter.
darker := baseColor muchDarker.
""
^ (lighter diff: baseColor) > (darker diff: baseColor)
ifTrue: [lighter]
ifFalse: [darker]!
----- Method: AxesMorph>>dataPointToGridPoint: (in category 'utility') -----
dataPointToGridPoint: aPoint
"Compute the pixel coordinates wrt the grid origin of the given data point."
| drawBounds |
drawBounds := self drawBounds.
^ (aPoint - self minPoint) * (drawBounds width @ drawBounds height negated).
!
----- Method: AxesMorph>>dataPointToWorldPoint: (in category 'utility') -----
dataPointToWorldPoint: aPoint
"Compute the pixel coordinates wrt the World origin of the given data point."
^ (self dataPointToGridPoint: aPoint) + self gridOrigin!
----- Method: AxesMorph>>drawBounds (in category 'geometry') -----
drawBounds
"answer the rectangle inside the morph where the plot is drawn"
^ (0 @ 0 rect: self width @ self height - (self borderWidth * 2))
insetBy: margin!
----- 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]!
----- Method: AxesMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
super drawOn: aCanvas.
aCanvas
image: self form
at: self topLeft + self borderWidth
rule: Form blend!
----- Method: AxesMorph>>extent: (in category 'geometry') -----
extent: aPoint
super
extent: (aPoint max: self minExtent)!
----- Method: AxesMorph>>externalName (in category 'naming') -----
externalName
^ super externalName, (title contents isEmpty ifTrue:[''] ifFalse:[' - ', title contents])!
----- Method: AxesMorph>>form (in category 'drawing') -----
form
form ifNil: [
Cursor wait showWhile: [
form := Form
extent: (self bounds insetBy: self borderWidth) extent
depth: Display depth.
form fillColor: self color.
self updateForm]].
^ form!
----- Method: AxesMorph>>graphBounds: (in category 'accessing') -----
graphBounds: aRectangle
"Sets the axes and then draws."
Transcript cr; print: aRectangle; flush.
limitMinX := aRectangle left.
limitMinY := aRectangle bottom.
limitMaxX := aRectangle right.
limitMaxY := aRectangle top.
self changed!
----- Method: AxesMorph>>gridOrigin (in category 'accessing') -----
gridOrigin
"Answer the intersection of the two axes (lower left corner of the grid)"
| inset |
inset := self borderWidth + margin.
^ self bottomLeft + (inset @ inset negated)!
----- Method: AxesMorph>>gridPointToDataPoint: (in category 'utility') -----
gridPointToDataPoint: aPoint
"Compute the coordinates of the data point corresponding to the given grid point (given in pixel coordinates wrt the grid origin)."
| drawBounds |
drawBounds := self drawBounds.
^ (aPoint x @ aPoint y negated) / (drawBounds extent) + self minPoint
!
----- Method: AxesMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
self color: Color gray.
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 at 1.!
----- Method: AxesMorph>>initializeCotas (in category 'initialization') -----
initializeCotas
drawCotas := true.
""
title := StringMorph contents: '' font: TextStyle defaultFont emphasis: 1.
xmax := StringMorph contents: ''.
xmid := StringMorph contents: ''.
xmin := StringMorph contents: ''.
ymax := StringMorph contents: ''.
ymid := StringMorph contents: ''.
ymin := StringMorph contents: ''.
""
self addMorph: title.
self addMorph: xmax.
self addMorph: xmid.
self addMorph: xmin.
self addMorph: ymax.
self addMorph: ymid.
self addMorph: ymin.
""
limitMinX := 0.
limitMaxX := 1.0.
limitMinY := 0.
limitMaxY := 1.0.!
----- Method: AxesMorph>>limitMaxX: (in category 'accessing') -----
limitMaxX: aNumberOrNil
"Set the maximum value along the X axis. If nil, this value will be computed from the data points to be displayed (subclass responsibility, since AxesMorph doesn't know anything about data)."
limitMaxX := aNumberOrNil.
self changed.!
----- Method: AxesMorph>>limitMaxY: (in category 'accessing') -----
limitMaxY: aNumberOrNil
"Set the maximum value along the X axis. If nil, this value will be computed from the data points to be displayed (subclass responsibility, since AxesMorph doesn't know anything about data)."
limitMaxY := aNumberOrNil.
self changed!
----- Method: AxesMorph>>limitMinX: (in category 'accessing') -----
limitMinX: aNumberOrNil
"Set the maximum value along the X axis. If nil, this value will be computed from the data points to be displayed (subclass responsibility, since AxesMorph doesn't know anything about data)."
limitMinX := aNumberOrNil.
self changed!
----- Method: AxesMorph>>limitMinX:limitMaxX: (in category 'accessing') -----
limitMinX: minNumberOrNil limitMaxX: maxNumberOrNil
"Set the minimum and maximum values along the X axis. If nil, these
values will be computed from the data points to be displayed (subclass
responsibility, since AxesMorph doesn't know anything about data)."
limitMinX := minNumberOrNil.
limitMaxX := maxNumberOrNil.
self changed!
----- Method: AxesMorph>>limitMinY: (in category 'accessing') -----
limitMinY: aNumberOrNil
"Set the maximum value along the X axis. If nil, this value will be computed from the data points to be displayed (subclass responsibility, since AxesMorph doesn't know anything about data)."
limitMinY := aNumberOrNil.
self changed!
----- Method: AxesMorph>>margin (in category 'accessing') -----
margin
"Answer the width of the margin surrounding the grid."
^margin!
----- Method: AxesMorph>>margin: (in category 'accessing') -----
margin: anInteger
"Set the size of the margin surrounding the grid."
margin := anInteger.
self changed!
----- Method: AxesMorph>>maxPoint (in category 'drawing') -----
maxPoint
"Limit values must be non-nil"
^ limitMaxX @ limitMaxY!
----- Method: AxesMorph>>minExtent (in category 'geometry') -----
minExtent
^ 125 @ 125 + margin !
----- Method: AxesMorph>>minPoint (in category 'drawing') -----
minPoint
"Limit values must be non-nil"
^ limitMinX @ limitMinY!
----- Method: AxesMorph>>referenceColor (in category 'accessing') -----
referenceColor
"This name is confusing because it sounds like it has something to do with PlotMorphs 'references' instance variable."
self deprecatedExplanation: 'use #baseColor instead'.
^ self baseColor!
----- Method: AxesMorph>>shouldDrawAxis: (in category 'accessing') -----
shouldDrawAxis: aBoolean
grid drawAxis: aBoolean.
self changed!
----- Method: AxesMorph>>shouldDrawCotas: (in category 'accessing') -----
shouldDrawCotas: aBoolean
aBoolean = drawCotas ifTrue: [^self].
""
drawCotas := aBoolean.
title visible: aBoolean.
xmax visible: aBoolean.
xmid visible: aBoolean.
xmin visible: aBoolean.
ymax visible: aBoolean.
ymid visible: aBoolean.
ymin visible: aBoolean.
""
self changed!
----- Method: AxesMorph>>shouldDrawGrid: (in category 'accessing') -----
shouldDrawGrid: aBoolean
grid drawGrid: aBoolean.
self changed!
----- Method: AxesMorph>>title: (in category 'accessing') -----
title:aString
title contents: aString!
----- Method: AxesMorph>>updateCotas (in category 'drawing') -----
updateCotas
| cotaColor |
xmax isNil
ifTrue: [^ self].
""
cotaColor := self cotaColor.
title color: cotaColor.
xmax color: cotaColor.
xmid color: cotaColor.
xmin color: cotaColor.
ymax color: cotaColor.
ymid color: cotaColor.
ymin color: cotaColor.
""
xmax
contents: (xAxisFormatter value: self maxPoint x).
xmid
contents: (xAxisFormatter value: self maxPoint x + self minPoint x / 2).
xmin
contents: (xAxisFormatter value: self minPoint x).
ymax
contents: (yAxisFormatter value: self maxPoint y).
ymid
contents: (yAxisFormatter value: self maxPoint y + self minPoint y / 2).
ymin
contents: (yAxisFormatter value: self minPoint y).
""
title position: self topLeft + ((self width - title width / 2) rounded @ 0) + (0 @ self borderWidth).
""
xmax position: self topLeft + (self width - xmax width @ (self height - xmax height)) - (margin @ self borderWidth).
xmid position: self topLeft + ((self width - xmid width / 2) rounded @ (self height - xmid height)) - (0 @ self borderWidth).
xmin position: self topLeft + (0 @ (self height - xmin height)) + (margin @ 0) - (0 @ self borderWidth).
""
ymax position: self topLeft + ((0 - ymax width max: 0)
@ 0) + (self borderWidth @ margin).
ymid position: self topLeft + ((15 - ymid width max: 0)
@ (self height - ymid height / 2) rounded) + (self borderWidth @ 0).
ymin position: self topLeft + ((0 - ymin width max: 0)
@ (self height - ymin height)) - (0 @ margin) + (self borderWidth @ 0)!
----- Method: AxesMorph>>updateForm (in category 'drawing') -----
updateForm
self updateCotas.
grid drawOn: form getCanvas.!
----- Method: AxesMorph>>worldPointToDataPoint: (in category 'utility') -----
worldPointToDataPoint: aPoint
"Compute the pixel coordinates of the given data point wrt the World origin."
^ self gridPointToDataPoint: aPoint - self gridOrigin
!
----- Method: AxesMorph>>xAxisFormatter: (in category 'accessing') -----
xAxisFormatter: aFormatterBlock
xAxisFormatter := aFormatterBlock.
self updateCotas!
----- Method: AxesMorph>>yAxisFormatter: (in category 'accessing') -----
yAxisFormatter: aFormatterBlock
yAxisFormatter := aFormatterBlock.
self updateCotas!
AxesMorph subclass: #PlotMorph
instanceVariableNames: 'series cachedMaxPoint cachedMinPoint lens scaledPoints references processMouseDown balloonFormatter'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!PlotMorph commentStamp: 'dgd 10/11/2003 21:12' prior: 0!
I can draw many series of Points in a XY grid. See the methods testXXX in the class side.
Samples:
PlotMorph test.
PlotMorph test2.
PlotMorph test4.
PlotMorph testWithReferences.
!
----- Method: PlotMorph class>>plotPoints: (in category 'instance creation') -----
plotPoints: aPointOrderedCollection
| plotMorph |
plotMorph := PlotMorph new.
plotMorph color: Color black twiceLighter twiceLighter;
title: 'Colors';
extent: 700 @ 300;
useRoundedCorners;
borderRaised.
plotMorph series: #series color: Color white;
series: #series drawLine: false.
aPointOrderedCollection
do: [:e | ""
plotMorph series: #series addPoint: e].
plotMorph openInWorld.
^ plotMorph!
----- Method: PlotMorph class>>plotSeries: (in category 'instance creation') -----
plotSeries: aPointOrderedCollection
| plotMorph |
plotMorph := PlotMorph new.
plotMorph color: Color gray lighter;
title: 'Colors';
extent: 700 @ 300;
useRoundedCorners;
borderRaised.
plotMorph series: #series color: Color red;
series: #series drawLine: false.
aPointOrderedCollection
do: [:e | ""
plotMorph series: #series addPoint: e].
plotMorph openInWorld.
^ plotMorph!
----- Method: PlotMorph class>>test (in category 'testing') -----
test
"
PlotMorph test
"
| pm |
pm := PlotMorph new.
pm
color: (Color
r: 0.0
g: 0.376
b: 0.317);
extent: 320 @ 320;
borderWidth: 2;
useRoundedCorners;
setBorderStyle: #raised;
title: 'Some test functions'.
pm series: #sin color: Color red;
series: #cos color: Color blue;
series: #test color: Color yellow.
pm series: #sin drawArea: true;
series: #cos drawArea: true;
series: #test drawArea: true.
pm series: #sin description: 'sin';
series: #cos description: 'cosin';
series: #test description: 'test'.
pm series: #test type: #stepped.
pm series: #sin width: 2;
series: #sin drawLine: false.
""
pm
yAxisFormatter: [:y | (y roundTo: 0.1) asString].
""
0
to: 360
by: 10
do: [:x |
pm series: #sin addPoint: x @ x degreesToRadians sin.
pm series: #cos addPoint: x @ x degreesToRadians cos.
pm series: #test addPoint: x @ (x degreesToRadians cos + x degreesToRadians sin)].
""
pm openInWorld!
----- Method: PlotMorph class>>test2 (in category 'testing') -----
test2
"
PlotMorph test2
"
| pm sigmoid |
pm := PlotMorph new.
pm title: 'Sigmoid';
extent: 250 @ 250;
color: Color black.
""
pm series: #sigmoid1 color: Color red;
series: #sigmoid1 drawPoints: false;
series: #sigmoid2 color: Color blue;
series: #sigmoid2 drawPoints: false;
series: #sigmoid3 color: Color yellow;
series: #sigmoid3 drawPoints: false;
series: #sigmoid4 color: Color green;
series: #sigmoid4 drawPoints: false;
series: #sigmoid5 color: Color white;
series: #sigmoid5 drawPoints: false.
""
pm
yAxisFormatter: [:y | (y roundTo: 0.1) asString].
sigmoid := [:x :slope | 1 / (1 + (slope * x) negated exp)].
-10
to: 10
by: 0.25
do: [:x |
pm series: #sigmoid1 addPoint: x
@ (sigmoid value: x value: 3).
pm series: #sigmoid2 addPoint: x
@ (sigmoid value: x value: 2).
pm series: #sigmoid3 addPoint: x
@ (sigmoid value: x value: 1).
pm series: #sigmoid4 addPoint: x
@ (sigmoid value: x value: 1 / 2).
pm series: #sigmoid5 addPoint: x
@ (sigmoid value: x value: 1 / 3)].
pm openInWorld!
----- Method: PlotMorph class>>test4 (in category 'testing') -----
test4
"
PlotMorph test4
"
| pm function |
pm := PlotMorph new.
pm
color: (Color blue twiceDarker twiceDarker twiceDarker alpha: 0.3);
extent: 300 @ 300;
useRoundedCorners.
pm
xAxisFormatter: [:x | x rounded asStringWithCommas].
pm
yAxisFormatter: [:y | y rounded asString].
pm title: 'Some funny function'.
pm series: #test2 color: Color red;
series: #test2 drawPoints: false.
function := [:x | x degreesToRadians sin / 5 + ((x / 10) degreesToRadians cos + (x / 10) degreesToRadians sin) * 100].
0
to: 3000
by: 5
do: [:x | pm series: #test2 addPoint: x
@ (function value: x)].
pm openInWorld!
----- Method: PlotMorph class>>testWithReferences (in category 'testing') -----
testWithReferences
"
PlotMorph testWithReferences.
"
| pm ref |
ref := AlignmentMorph newColumn.
ref color: Color magenta twiceDarker twiceDarker;
hResizing: #shrinkWrap;
vResizing: #shrinkWrap;
wrapCentering: #center;
cellPositioning: #leftCenter.
""
pm := PlotMorph new.
pm references: ref.
pm color: Color magenta twiceDarker twiceDarker;
extent: 300 @ 300;
borderWidth: 0;
title: 'Some test functions'.
pm series: #sin color: Color red;
series: #cos color: Color blue;
series: #test color: Color yellow.
pm series: #sin drawArea: true;
series: #cos drawArea: true;
series: #test drawArea: true.
pm series: #sin description: 'sin';
series: #cos description: 'cosin';
series: #test description: 'test'.
pm series: #test type: #stepped.
0
to: 360
by: 10
do: [:x |
pm series: #sin addPoint: x @ x degreesToRadians sin.
pm series: #cos addPoint: x @ x degreesToRadians cos.
pm series: #test addPoint: x @ (x degreesToRadians cos + x degreesToRadians sin)].
""
ref openInWorld.
pm openInWorld!
----- Method: PlotMorph>>balloonFormatter: (in category 'accessing') -----
balloonFormatter: anObject
balloonFormatter := anObject!
----- Method: PlotMorph>>changed (in category 'change reporting') -----
changed
cachedMaxPoint := nil.
cachedMinPoint := nil.
super changed!
----- Method: PlotMorph>>clear (in category 'accessing') -----
clear
series do:[:each | each clear].
self seriesChanged!
----- Method: PlotMorph>>exploreExtrasAt: (in category 'private') -----
exploreExtrasAt: nearPoint
| extras |
extras := (self scaledPoints at: nearPoint)
collect: [:each | each extra].
extras := extras
select: [:each | each notNil].
extras isEmpty ifFalse:[
extras explore]!
----- Method: PlotMorph>>findNearestPointTo: (in category 'private') -----
findNearestPointTo: targetPoint
| nearestPoint |
nearestPoint := nil.
Cursor wait
showWhile: [""
self scaledPoints
keysDo: [:scaledPoint | ""
(nearestPoint isNil
or: [(targetPoint dist: scaledPoint)
< (targetPoint dist: nearestPoint)])
ifTrue: [nearestPoint := scaledPoint]]].
^ nearestPoint!
----- Method: PlotMorph>>handlesMouseDown: (in category 'event handling') -----
handlesMouseDown: evt
^ processMouseDown!
----- Method: PlotMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
series := Dictionary new.
processMouseDown := true.
lens := nil.
balloonFormatter := [:aCollection | self textForBalloon: aCollection].
self extent: 1 @ 1!
----- Method: PlotMorph>>initializeCotas (in category 'initialization') -----
initializeCotas
"Don't put initial limits on the grid range... default is to compute them from series data."
super initializeCotas.
limitMinX := limitMaxX := limitMinY := limitMaxY := nil.!
----- Method: PlotMorph>>maxPoint (in category 'drawing') -----
maxPoint
cachedMaxPoint
ifNil: [""
limitMaxX notNil & limitMaxY notNil
ifTrue: [cachedMaxPoint := limitMaxY @ limitMaxY]
ifFalse: [| maxPoints |
maxPoints := series
collect: [:serie | serie maxPoint]
thenSelect: [:point | point notNil].
cachedMaxPoint := maxPoints isEmpty
ifTrue: [1 @ 1]
ifFalse: [maxPoints max].
limitMaxX notNil
ifTrue: [cachedMaxPoint := limitMaxX @ cachedMaxPoint y].
limitMaxY notNil
ifTrue: [cachedMaxPoint := cachedMaxPoint x @ limitMaxY]]].
^ cachedMaxPoint!
----- Method: PlotMorph>>minPoint (in category 'drawing') -----
minPoint
cachedMinPoint
ifNil: [""
limitMinX notNil & limitMinY notNil
ifTrue: [cachedMinPoint := limitMinX @ limitMinY]
ifFalse: [| minPoints |
minPoints := series
collect: [:serie | serie minPoint]
thenSelect: [:point | point notNil].
cachedMinPoint := minPoints isEmpty
ifTrue: [0 @ 0]
ifFalse: [minPoints min].
limitMinX notNil
ifTrue: [cachedMinPoint := limitMinX
@ cachedMinPoint y].
limitMinY notNil
ifTrue: [cachedMinPoint := cachedMinPoint x
@ limitMinY]]].
^ cachedMinPoint!
----- Method: PlotMorph>>mouseDown: (in category 'event handling') -----
mouseDown: anEvent
| nearPoint |
nearPoint := self findNearestPointTo: anEvent position - self topLeft - self borderWidth.
nearPoint
ifNotNil: [anEvent redButtonChanged
ifTrue: [self showLensAt: nearPoint]
ifFalse: [self exploreExtrasAt: nearPoint]]!
----- Method: PlotMorph>>mouseUp: (in category 'event handling') -----
mouseUp: anEvent
lens isNil ifTrue:[^ self].
""
lens deleteBalloon.
lens delete.
lens := nil!
----- Method: PlotMorph>>processMouseDown: (in category 'accessing') -----
processMouseDown: aBoolean
processMouseDown := aBoolean!
----- Method: PlotMorph>>references: (in category 'accessing') -----
references: aMorphOrNil
"Specifies a morph (if not nil) that is updated with the names of the plotted series, displayed in the same color as the actual plot."
references := aMorphOrNil!
----- Method: PlotMorph>>scalePoints (in category 'drawing') -----
scalePoints
| |
scaledPoints := nil.
series
do: [:serie | serie
scaleTo: self drawBounds
height: self height - (self borderWidth * 2)
maxPoint: self maxPoint
minPoint: self minPoint]!
----- Method: PlotMorph>>scaledPoints (in category 'drawing') -----
scaledPoints
^ scaledPoints
ifNil: [scaledPoints := Dictionary new.
series
do: [:serie | serie points
do: [:point |
| allPoints |
allPoints := scaledPoints
at: point scaledPoint
ifAbsentPut: [OrderedCollection new].
allPoints add: point]].
scaledPoints]!
----- Method: PlotMorph>>series (in category 'accessing') -----
series
^series!
----- Method: PlotMorph>>series: (in category 'series') -----
series: aSeriesOrSymbol
"If aSeriesOrSymbol is a PlotSeries, simply answer it. Otherwise, it should be a string, and the returned value is the series with that name."
^ aSeriesOrSymbol isString
ifTrue: [| symbol |
symbol := aSeriesOrSymbol asSymbol.
series
at: symbol
ifAbsentPut: [PlotSeries name: symbol]]
ifFalse: [aSeriesOrSymbol]!
----- Method: PlotMorph>>series:addPoint: (in category 'series') -----
series: aSymbol addPoint: aPoint
"Find the appropriate series and set a property in it."
(self series: aSymbol)
addPoint: aPoint.
self changed!
----- Method: PlotMorph>>series:addPoint:extra: (in category 'series') -----
series: aSymbol addPoint: aPoint extra: anObject
"Find the appropriate series and set a property in it."
(self series: aSymbol)
addPoint: aPoint
extra: anObject.
self changed !
----- Method: PlotMorph>>series:color: (in category 'series') -----
series: aSymbol color: aColor
"Find the appropriate series and set a property in it."
(self series:aSymbol) color:aColor.
self changed!
----- Method: PlotMorph>>series:description: (in category 'series') -----
series: aSymbol description: aString
"Find the appropriate series and set a property in it."
(self series: aSymbol)
description: aString.
self changed!
----- Method: PlotMorph>>series:drawArea: (in category 'series') -----
series: aSymbol drawArea: aBoolean
"Find the appropriate series and set a property in it."
(self series: aSymbol)
drawArea: aBoolean.
self changed!
----- Method: PlotMorph>>series:drawLine: (in category 'series') -----
series: aSymbol drawLine: aBoolean
"Find the appropriate series and set a property in it."
(self series: aSymbol)
drawLine: aBoolean.
self changed!
----- Method: PlotMorph>>series:drawPoints: (in category 'series') -----
series: aSymbol drawPoints: aBoolean
"Find the appropriate series and set a property in it."
(self series: aSymbol)
drawPoints: aBoolean.
self changed!
----- Method: PlotMorph>>series:type: (in category 'series') -----
series: seriesSymbol type: lineTypeSymbol
"Find the appropriate series and set a property in it."
(self series: seriesSymbol)
type: lineTypeSymbol.
self changed!
----- Method: PlotMorph>>series:width: (in category 'series') -----
series: aSymbol width: anInteger
"Find the appropriate series and set a property in it."
(self series: aSymbol) width: anInteger.
self changed!
----- Method: PlotMorph>>seriesChanged (in category 'private') -----
seriesChanged
cachedMaxPoint := nil.
cachedMinPoint := nil.
"If the morphs has no owner, then the morph is not open yet"
owner isNil
ifTrue:[^ self].
""
self changed.
self updateCotas!
----- Method: PlotMorph>>showLensAt: (in category 'private') -----
showLensAt: nearPoint
lens := EllipseMorph new.
lens
color: (Color red alpha: 0.5).
lens extent: 7 @ 7.
self addMorph: lens.
lens position: self topLeft + nearPoint - (3 @ 3) + self borderWidth.
lens
showBalloon: (balloonFormatter
value: (self scaledPoints at: nearPoint))!
----- Method: PlotMorph>>textForBalloon: (in category 'private') -----
textForBalloon: aCollection
| stream point |
point := aCollection anyOne.
stream := String new writeStream.
stream
nextPutAll: (xAxisFormatter value: point x);
nextPutAll: ' ';
nextPutAll: (yAxisFormatter value: point y);
nextPut: Character cr.
aCollection
do: [:each |
stream nextPutAll: each series name.
each extra
ifNotNil: [stream nextPutAll: ': ';
print: each extra]]
separatedBy: [stream nextPut: Character cr].
^ stream contents!
----- Method: PlotMorph>>updateForm (in category 'drawing') -----
updateForm
"Override superclass implementation to do drawing of data."
| canvas |
self updateReferences.
self updateCotas.
self scalePoints.
canvas := form getCanvas.
grid drawOn: canvas.
(series values
asSortedCollection: [:x :y | x name <= y name])
do: [:serie | serie drawOn: canvas].
!
----- Method: PlotMorph>>updateReferences (in category 'drawing') -----
updateReferences
"Update a 'legend' displaying the description of each plotted series in the same color as that series."
| seriesWithDescription sortedSeried |
references isNil
ifTrue: [^ self].
""
references removeAllMorphs.
""
seriesWithDescription := series
reject: [:each | each description isEmpty].
sortedSeried := seriesWithDescription
asSortedCollection: [:x :y | x description asLowercase <= y description asLowercase].
sortedSeried
do: [:serie |
| ref |
ref := StringMorph new.
ref contents: serie description.
ref color: serie color.
references addMorphBack: ref.
serie]!
PlotMorph subclass: #VMProfilePlotMorph
instanceVariableNames: 'alternateSeries selectionStart selectionStop oldSelectionRectangle model cachedAlternateMaxPoint cachedAlternateMinPoint aymax aymid aymin'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
----- Method: VMProfilePlotMorph 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.'!
----- Method: VMProfilePlotMorph class>>model: (in category 'instance creation') -----
model: aProfiler
^self new model: aProfiler; yourself!
----- Method: VMProfilePlotMorph>>alternateMaxPoint (in category 'drawing') -----
alternateMaxPoint
cachedAlternateMaxPoint ifNil:
[| maxPoints |
maxPoints := alternateSeries
collect: [:serie | serie maxPoint]
thenSelect: [:point | point notNil].
cachedAlternateMaxPoint := maxPoints isEmpty
ifTrue: [1 @ 1]
ifFalse: [maxPoints max]].
^cachedAlternateMaxPoint!
----- Method: VMProfilePlotMorph>>alternateMinPoint (in category 'drawing') -----
alternateMinPoint
cachedAlternateMinPoint ifNil:
[| minPoints |
minPoints := alternateSeries
collect: [:serie | serie minPoint]
thenSelect: [:point | point notNil].
cachedAlternateMinPoint := minPoints isEmpty
ifTrue: [1 @ 1]
ifFalse: [minPoints min]].
^cachedAlternateMinPoint!
----- Method: VMProfilePlotMorph>>alternateSeries: (in category 'series') -----
alternateSeries: aSeriesOrSymbol
"If aSeriesOrSymbol is a PlotSeries, simply answer it. Otherwise, it should be a string, and the returned value is the series with that name."
^ aSeriesOrSymbol isString
ifTrue: [| symbol |
symbol := aSeriesOrSymbol asSymbol.
alternateSeries
at: symbol
ifAbsentPut: [PlotSeries name: symbol]]
ifFalse: [aSeriesOrSymbol]!
----- Method: VMProfilePlotMorph>>changed (in category 'change reporting') -----
changed
cachedAlternateMaxPoint := cachedAlternateMinPoint := nil.
super changed!
----- Method: VMProfilePlotMorph>>clear (in category 'accessing') -----
clear
alternateSeries do:[:each | each clear].
super clear!
----- Method: VMProfilePlotMorph>>drawOn: (in category 'drawing') -----
drawOn: aCanvas
self selectionRectangle ifNotNil:
[:selectionRectangle|
aCanvas fillRectangle: selectionRectangle color: Color lightBlue].
super drawOn: aCanvas!
----- Method: VMProfilePlotMorph>>initialize (in category 'initialization') -----
initialize
super initialize.
alternateSeries := Dictionary new!
----- Method: VMProfilePlotMorph>>initializeCotas (in category 'initialization') -----
initializeCotas
super initializeCotas.
aymax := StringMorph contents: ''.
aymid := StringMorph contents: ''.
aymin := StringMorph contents: ''.
self addMorph: aymax.
self addMorph: aymid.
self addMorph: aymin!
----- 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]!
----- Method: VMProfilePlotMorph>>model (in category 'accessing') -----
model
^model!
----- 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!
----- Method: VMProfilePlotMorph>>mouseDown: (in category 'event handling') -----
mouseDown: anEvent
selectionStart := anEvent position x.
self invalidateSelection!
----- Method: VMProfilePlotMorph>>mouseMove: (in category 'event handling') -----
mouseMove: anEvent
selectionStop := anEvent position x.
self invalidateSelection!
----- 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)]!
----- Method: VMProfilePlotMorph>>scalePoints (in category 'drawing') -----
scalePoints
super scalePoints.
alternateSeries do:
[:serie |
serie
scaleTo: self drawBounds
height: self height - (self borderWidth * 2)
maxPoint: self alternateMaxPoint
minPoint: self alternateMinPoint]!
----- 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]!
----- Method: VMProfilePlotMorph>>seriesChanged (in category 'private') -----
seriesChanged
cachedAlternateMaxPoint := cachedAlternateMinPoint := nil.
super seriesChanged!
----- Method: VMProfilePlotMorph>>updateCotas (in category 'drawing') -----
updateCotas
| cotaColor |
super updateCotas.
aymax isNil
ifTrue: [^ self].
""
cotaColor := self cotaColor.
aymax color: cotaColor.
aymid color: cotaColor.
aymin color: cotaColor.
aymax
contents: (yAxisFormatter value: self alternateMaxPoint y).
aymid
contents: (yAxisFormatter value: self alternateMaxPoint y + self alternateMinPoint y / 2).
aymin
contents: (yAxisFormatter value: self alternateMinPoint y).
""
aymax position: self topRight
- ((aymax width + self borderWidth) @ 0)
+ (0 at self borderWidth).
aymid position: self topRight
- (aymid width + self borderWidth @ 0)
+ (0 @ (self height - aymid height / 2) rounded).
aymin position: self topRight
- (aymin width + self borderWidth @ 0)
+ (0 @ (self height - aymin height - margin - self borderWidth) rounded).!
----- Method: VMProfilePlotMorph>>updateForm (in category 'drawing') -----
updateForm
| canvas |
super updateForm.
canvas := form getCanvas.
(alternateSeries values
asSortedCollection: [:x :y | x name <= y name])
do: [:serie | serie drawOn: canvas].
!
----- Method: CompiledMethod>>methodPCData (in category '*CogTools-method introspection') -----
methodPCData
"If the method is linked to a cogit method, answers the values of the bytecode and
machine code pc pairs which are mapped to each other in the VM. The first two
pairs have nil byetcode pcs and map to the checked and unchecked entrypoints
for methods and the no-context-switch and normal entries for blocks."
<primitive: 'primitiveMethodPCData' module:''>
^#()!
Point subclass: #PlotPoint
instanceVariableNames: 'series scaledPoint extra'
classVariableNames: ''
poolDictionaries: ''
category: 'CogTools-VMProfiler'!
!PlotPoint commentStamp: '<historical>' prior: 0!
PlotPoint is a point that have more data used to draw in a PlotMorph!
----- Method: PlotPoint class>>at:serie: (in category 'instance creation') -----
at: aPoint serie: aPlotSerie
^ self new initializeAt: aPoint series: aPlotSerie!
----- Method: PlotPoint class>>at:serie:extra: (in category 'instance creation') -----
at: aPoint serie: aPlotSerie extra: anObject
^ self new
initializeAt: aPoint
serie: aPlotSerie
extra: anObject!
----- Method: PlotPoint class>>at:series: (in category 'instance creation') -----
at: aPoint series: aPlotSeries
^ self new initializeAt: aPoint series: aPlotSeries!
----- Method: PlotPoint class>>at:series:extra: (in category 'instance creation') -----
at: aPoint series: aPlotSeries extra: anObject
^ self new
initializeAt: aPoint
series: aPlotSeries
extra: anObject!
----- Method: PlotPoint class>>new (in category 'instance creation') -----
new
^super new initialize!
----- Method: PlotPoint>>= (in category 'comparing') -----
= anObject
^ super = anObject
and: [series = anObject series
and: [extra = anObject extra]]!
----- Method: PlotPoint>>extra (in category 'accessing') -----
extra
^extra!
----- Method: PlotPoint>>hash (in category 'comparing') -----
hash
^ super hash
bitXor: (series hash bitXor: extra hash)!
----- Method: PlotPoint>>initialize (in category 'initialization') -----
initialize
scaledPoint := self!
----- Method: PlotPoint>>initializeAt:series: (in category 'initialization') -----
initializeAt: aPoint series: aPlotSeries
self setX: aPoint x setY: aPoint y.
series := aPlotSeries!
----- Method: PlotPoint>>initializeAt:series:extra: (in category 'initialization') -----
initializeAt: aPoint series: aPlotSeries extra: anObject
self setX: aPoint x setY: aPoint y.
series := aPlotSeries.
extra := anObject!
----- Method: PlotPoint>>printOn: (in category 'printing') -----
printOn: aStream
super printOn: aStream.
aStream nextPutAll: ' series:(';
print: series;
nextPutAll: ') scaled:';
print: scaledPoint.
extra isNil
ifFalse: [aStream nextPutAll: ' extra:';
print: extra]!
----- Method: PlotPoint>>scaledPoint (in category 'accessing') -----
scaledPoint
^ scaledPoint ifNil:[self]!
----- Method: PlotPoint>>scaledPoint: (in category 'accessing') -----
scaledPoint: anObject
scaledPoint := anObject!
----- Method: PlotPoint>>series (in category 'accessing') -----
series
^ series!
More information about the Vm-dev
mailing list