VM Maker: CogTools-sk.14.mcz
Locked
 
|
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! |
«
Return to Squeak VM
|
1 view|%1 views
| Free forum by Nabble | Edit this page |