Quantcast

VM Maker: CogTools-sk.14.mcz

Previous Topic Next Topic
 
classic Classic list List threaded Threaded
1 message Options
Reply | Threaded
Open this post in threaded view
|  
Report Content as Inappropriate

VM Maker: CogTools-sk.14.mcz

commits-2
 
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@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@0 corner: 1@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@0 corner: 0.15@1);
                addMorph: (graph := VMProfilePlotMorph model: self) frame: (0.15@0 corner: 1.0@0.7);
                addMorph: labelsMorph frame: (0.15@0.7 corner: 1.0@0.85);
                "address boxes"
                addMorph: (self addressTextMorph:'Type the low address of the histogram here'
                                                get: #lowAddressText
                                                set: #lowAddressText:)
                        frame: (0.16@0.86 corner: 0.27@0.91);
                addMorph: (self addressTextMorph:'Type the high address of the histogram here'
                                                get: #highAddressText
                                                set: #highAddressText:)
                        frame: (0.88@0.86 corner: 0.99@0.91);
                addMorph: (self totalTextMorph: 'Shows the total number of samples' get: #totalText)
                        frame: (0.88@0.92 corner: 0.99@0.98);
                "symbol list check-box filters"
                addMorph: (self checkMorph: 'show module symbols'
                                                get: #showingModules
                                                set: #toggleShowModules)
                        frame: (0.16@0.915 corner: 0.175@0.93);
                addMorph: (buttons addLast: (StringMorph contents: 'modules'))
                        frame: (0.19@0.915 corner: 0.27@0.93);
                addMorph: (self checkMorph: 'show extern symbols'
                                                get: #showingPublicFunctions
                                                set: #toggleShowPublicFunctions)
                        frame: (0.16@0.935 corner: 0.175@0.95);
                addMorph: (buttons addLast: (StringMorph contents: 'externs'))
                        frame: (0.19@0.935 corner: 0.27@0.95);
                addMorph: (self checkMorph: 'show static symbols'
                                                get: #showingPrivateFunctions
                                                set: #toggleShowPrivateFunctions)
                        frame: (0.16@0.955 corner: 0.175@0.97);
                addMorph: (buttons addLast: (StringMorph contents: 'statics'))
                        frame: (0.19@0.955 corner: 0.27@0.97);
                addMorph: (self checkMorph: 'show static symbols'
                                                get: #showingLabels
                                                set: #toggleShowLabels)
                        frame: (0.16@0.975 corner: 0.175@0.99);
                addMorph: (buttons addLast: (StringMorph contents: 'labels'))
                        frame: (0.19@0.975 corner: 0.27@0.99);
                "history buttons"
                addMorph: (self historyButtonMorph: #backwardsButton help: 'go back to previous selection'
                                                set: #regress enable: #hasHistory color: #hasHistoryColor)
                        frame: (0.28@0.86 corner: 0.315@0.90);
                addMorph: (self historyButtonMorph: #forwardsButton help: 'go forward to next selection'
                                                set: #progress enable: #hasFuture color: #hasFutureColor)
                        frame: (0.32@0.86 corner: 0.355@0.90);
                "profiling buttons"
                addMorph: (self buttonMorph: #drawButton help: 'plot the graph'
                                                set: #plotGraph enable: #notProfilingAndData color: #clearColor)
                        frame: (0.37@0.86 corner: 0.45@0.91);
                addMorph: (self buttonMorph: #clearButton help: 'clear the histogram data'
                                                set: #clearProfile enable: #notProfiling color: #clearColor)
                        frame: (0.46@0.86 corner: 0.54@0.91);
                addMorph: (self buttonMorph: #startButton help: 'start the profiler'
                                                set: #startProfiling enable: #notProfiling color: #profileColor)
                        frame: (0.28@0.915 corner: 0.36@0.96);
                addMorph: (self buttonMorph: #stopButton help: 'stop the profiler'
                                                set: #stopProfiling enable: #profiling color: #stopColor)
                        frame: (0.37@0.915 corner: 0.45@0.96);
                addMorph: (self buttonMorph: #profileExpressionButton help: 'compile and profile the expression to the right'
                                                set: #profileExpression enable: #notProfiling color: #profileColor)
                        frame: (0.46@0.915 corner: 0.54@0.96);
                addMorph: expressionTextMorph
                        frame: (0.55@0.86 corner: 0.87@0.98);
                addMorph: (self checkMorph: 'Run the full garbage collector prior to profiling'
                                                get: #gcPriorToProfile
                                                set: #toggleGcPriorToProfile)
                        frame: (0.28@0.97 corner: 0.295@0.985);
                addMorph: (buttons addLast: (StringMorph contents: 'gc prior'))
                        frame: (0.30@0.97 corner: 0.365@0.995);
                addMorph: (self checkMorph: 'Clear the profile prior to profiling'
                                                get: #clearPriorToProfile
                                                set: #toggleClearPriorToProfile)
                        frame: (0.37@0.97 corner: 0.385@0.985);
                addMorph: (buttons addLast: (StringMorph contents: 'clear prior'))
                        frame: (0.39@0.97 corner: 0.455@0.995);
                addMorph: (self checkMorph: 'Run the profiled expression in its own process'
                                                get: #forkProfile
                                                set: #toggleForkProfile)
                        frame: (0.46@0.97 corner: 0.475@0.985);
                addMorph: (buttons addLast: (StringMorph contents: 'fork profile'))
                        frame: (0.48@0.97 corner: 0.545@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@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@0 extent: side@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@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@0)
                                sourceRect: rotatedLabelForm boundingBox
                                rule: Form erase.
                        true ifTrue:
                                [| box |
                                 box := (self bounds origin + ((fractionalX * range) floor + margin@0)) extent: 1@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@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@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!

Loading...