!=========================================================================
! Copyright (C) VMware, Inc. 1986-2011.  All Rights Reserved.
!
! $Id: profmonitor.gs,v 1.9 2008-01-09 22:50:13 stever Exp $
!
! Superclass Hierarchy:
!   ProfMonitor, Object.
!
!=========================================================================

expectvalue %String
run
Object _newKernelSubclass: 'ProfMonitor'
  instVarNames: #(#file #interval #results #sampleDepth #startTime #endTime 
		  #traceObjCreation #rawSampleArray )
  classVars: #(#Entry #EntrySet)
  classInstVars: #()
  poolDictionaries: #[]
  inDictionary: Globals
  constraints: #()
  instancesInvariant: false
  isModifiable: false
  reservedOop: 731
%

! remove existing behavior from ProfMonitor
removeallmethods ProfMonitor
removeallclassmethods ProfMonitor

category: 'For Documentation Installation only'
classmethod: ProfMonitor
installDocumentation

| doc txt |
doc := GsClassDocumentation newForClass: self.

txt := (GsDocText new) details:
'A ProfMonitor installs a timer to snapshot the execution stack at
 given intervals for a given period of time.  When done monitoring,
 the results are collected and formed into a report showing classes,
 method selectors and hit rates.
 
 The interval is the interval between sample points, which must be a
 postive integer.  Values less than 10 may not produce more frequent
 samples due to system-dependent OS clock resolution.  
 
 The sampleDepth is the number of levels from the top of the stack to
 sample.  Must be between 1 and 20 inclusive.  
 
 The results are recorded in an instance of GsFile for the gem session,
 in the /tmp directory, in binary machine dependent form.'.
doc documentClassWith: txt.

txt := (GsDocText new) details: 'Private.' .
doc documentClassVar: #EntrySet with: txt.

txt := (GsDocText new) details: 'Private.' .
doc documentClassVar: #Entry with: txt.

txt := (GsDocText new) details:
'An instance of GsFile used to record sampling information while profiling
 is active.  The file contains binary data in machine dependent form.'.
doc documentInstVar: #file with: txt.

txt := (GsDocText new) details:
'The interval between sample points, in milliseconds of CPU time. Must be a 
postive number.  Values less than 10 may not show up in results due to OS 
resolution limitations.'.
doc documentInstVar: #interval with: txt.

txt := (GsDocText new) details:
'A Boolean.  If true, object creation statistics are included in the
 profiling.'.
doc documentInstVar: #traceObjCreation with: txt.

txt := (GsDocText new) details: 'GemStone internal use only.' .
doc documentInstVar: #rawSampleArray with: txt.

txt := (GsDocText new) details:
'Holds collected, processed snapshot information in instances of a
 class that is private to ProfMonitor.'.
doc documentInstVar: #results with: txt.

txt := (GsDocText new) details:
'The number of levels from top of stack to sample.  Must be between 1 and 20
 inclusive.'.
doc documentInstVar: #sampleDepth with: txt.

txt := (GsDocText new) details:
'Starting CPU time (see System | _readClock).'.
doc documentInstVar: #startTime with: txt.

txt := (GsDocText new) details:
'Ending CPU time (see System | _readClock).'.
doc documentInstVar: #endTime with: txt.

self description: doc.
%

! ------------------- Class methods for ProfMonitor

category: 'Initialization'
classmethod: ProfMonitor
defaultInterval

"Returns the number of CPU milliseconds used for a monitoring interval if no
 interval is given."

^10
%

category: 'Initialization'
classmethod: ProfMonitor
initialize

"Private."

| dict |

dict := SymbolDictionary new.

Entry == nil ifTrue:
  [
  Entry := Object subclass: #ProfMonEntry 
    instVarNames: #( #cmethod #tally #senders #rcvrClasses)
    classVars:  #()  
    classInstVars:  #() 
    poolDictionaries: #[ ] 
    inDictionary: dict
    constraints: #[ #[#tally, SmallInteger] ] 
    instancesInvariant: false isModifiable: false .

  Entry compileAccessingMethodsFor: #(#cmethod #tally #senders #rcvrClasses).
  ].

EntrySet == nil ifTrue:
  [
  EntrySet := IdentitySet 
     subclass: #ProfMonEntrySet 
     instVarNames:  #() 
     classVars:  #()  
     classInstVars:  #() 
     poolDictionaries: #[ ] 
     inDictionary: dict
     constraints: Entry 
     instancesInvariant: false
     isModifiable: false .
  ].
%

category: 'Private'
classmethod: ProfMonitor
_reinitialize

"Reinitialize the ProfMonitor helper classes.  Needed after 4.0 conversion."

Entry := nil.
EntrySet := nil.

self initialize.
%

category: 'Quick Profiling'
classmethod: ProfMonitor
monitorBlock: aBlock

"This is a quick way to profile the execution of a block and get a report of
 the result.  An interval of 10 milliseconds is used, and the results
 are reported down to 1 hit per method.  Returns a formatted report of the
 results of the profile run."

| inst result |
inst := self new .
inst monitorBlock: aBlock.
result := inst reportDownTo: 1 .
inst removeResults .
^ result
%

category: 'Quick Profiling'
classmethod: ProfMonitor
monitorBlock: aBlock downTo: hits 

"This is a quick way to profile the execution of a block and get a report of
 the result.  Returns a formatted report of the results of the profile run."

| inst result |
inst := self new .
inst monitorBlock: aBlock.
inst reportDownTo: hits .
result := inst reportDownTo: 1 .
inst removeResults .
^ result
%

category: 'Quick Profiling'
classmethod: ProfMonitor
monitorBlock: aBlock downTo: hits interval: msecsPerSample

"This is a quick way to profile the execution of a block and get a report of
 the result.  The msecsPerSample argument gives the CPU time interval between
 samples in milliseconds.  The hits argument gives the minimum number of hits
 for a method to be included in the report."

| inst result |
inst := self basicNew initializeNoFile .
inst _createFile: self newProfileFileName;  interval: msecsPerSample .
inst monitorBlock: aBlock.
result := inst reportDownTo: hits .
inst removeResults .
^ result
%

category: 'Instance Creation'
classmethod: ProfMonitor
newWithFile: fileName

"Creates a new profiler with the given output file name and default monitoring
 interval."

^self newWithFile: fileName interval: self defaultInterval
%

category: 'Instance Creation'
classmethod: ProfMonitor
newWithFile: fileName interval: interval

"Creates a new profiler with the specified output file name and monitoring
 interval (in CPU milliseconds)."

^ self basicNew initializeNoFile _createFile: fileName; interval: interval; yourself
%

category: 'Instance Creation'
classmethod: ProfMonitor
new

"Returns a new profiler with default initialization."

^ self basicNew initialize
%

category: 'Quick Profiling'
classmethod: ProfMonitor
profileOn

"Creates a default instance, starts it monitoring, and returns it.
 To turn off profiling, send the message profileOff to the instance."

| inst |

inst := self new .
inst startMonitoring.
^inst.
%

category: 'Quick Profiling'
classmethod: ProfMonitor
spyOn: aBlock

"A convenience for Smalltalk programmers, this method merely fronts for
 ProfMonitor | monitorBlock:."

^self monitorBlock: aBlock
%

! possible fix for bug 12205
category: 'Private
classmethod: ProfMonitor
newProfileFileName

"Returns a String to be used as the name of a temporary file which will
 contain profiling data.  The file name will be /tmp/gem<processId>.pro,
 or gem<processId>.pro if a /tmp directory is not found."

| result pidStr aFile |
pidStr := (System gemVersionAt: #processId ) printString .
result := String withAll: '/tmp/gem'.
result  addAll: pidStr; addAll: '.pro' .

aFile := GsFile openWriteOnServer: result .
aFile ~~ nil ifTrue:[
  aFile close .
  ^ result
  ].
result := (String withAll: 'gem').
result addAll: pidStr; addAll: '.pro' .
^ result
%

category: 'Private'
classmethod: ProfMonitor
_getMethodCounts

"Returns an Array of GsMethod/invocationCount/physSize/isNative quadruples,
 and resets method invocation counts.

 Gemstone64 v2.0, invocation counts are not currently supported and may return
 uninitialized values."

<primitive: 192>
self _primitiveFailed: #_getMethodCounts
%

! ------------------- Instance methods for ProfMonitor
category: 'Updating'
method: ProfMonitor
interval: anInterval

"Assign the sampling interval of the receiver to be anInterval milliseconds.
 anInterval should be a positive SmallInteger."

interval := anInterval
%

category: 'Accessing'
method: ProfMonitor
fileName

"Returns the name of the active file."

file == nil ifTrue:[ ^ nil ].
^ file name
%

category: 'Private'
method: ProfMonitor
_createFile: fileName

"Creates the sampling file for writing with the specified file name."

file ~~ nil ifTrue:[ file close ] .
file := GsFile open: fileName mode: 'ab' onClient: false .
file == nil ifTrue:[
  fileName _error: #bkupErrOpenFailed
              args:#[ 'create' , GsFile serverErrorString ]
  ].
%

category: 'Private'
method: ProfMonitor
_openFileAppend

"Reopens the sampling file for writing."

| fileName |

file ~~ nil ifTrue:[ file close ] .
fileName := file pathName .
file := GsFile open: fileName mode: 'ab' onClient: false .
file == nil ifTrue:[
  fileName _error: #bkupErrOpenFailed
              args:#[ 'append' , GsFile serverErrorString ]
  ].
%

category: 'Private'
method: ProfMonitor
_openFileRead

"Reopens the sampling file for reading."

| fileName |

file ~~ nil ifTrue:[ file close ] .
fileName := file pathName .
file := GsFile open: fileName mode: 'rb' onClient: false .
file == nil ifTrue:[
  fileName _error: #bkupErrOpenFailed
              args:#[ 'read' , GsFile serverErrorString ]
  ].
%

category: 'Private'
method: ProfMonitor
forEntry: anEntry tallyRcvrClass: aClass 

"Private."

| dict rcvEntry |
aClass == nil ifTrue:[ ^ self ].
dict := anEntry rcvrClasses .
dict == nil ifTrue:[ 
  dict := IdentityKeyValueDictionary new .
  anEntry rcvrClasses: dict .
  ].
rcvEntry := dict at: aClass otherwise: nil .
rcvEntry == nil 
  ifTrue:[ rcvEntry := Entry new cmethod: aClass ; tally: 1 .
           dict at: aClass put: rcvEntry .]
  ifFalse:[ rcvEntry tally: rcvEntry tally + 1 ].
%

category: 'Private'
method: ProfMonitor
forEntry: anEntry tallySender: aSender 

"Private."

| dict sendEntry |
aSender _class == GsMethod ifFalse:[ 
  "ignore methods that were garbage collected and reused."
  ^ self 
  ].
dict := anEntry senders .
dict == nil ifTrue:[ 
  dict := IdentityKeyValueDictionary new .
  anEntry senders: dict .
  ].
sendEntry := dict at: aSender otherwise: nil .
sendEntry == nil 
  ifTrue:[ sendEntry := Entry new cmethod: aSender ; tally: 1 .
           dict at: aSender put: sendEntry .]
  ifFalse:[ sendEntry tally: sendEntry tally + 1 ].
%

category: 'Reporting'
method: ProfMonitor
gatherResults

"Analyze the receiver's file of sampling data and store the results of the
 analysis in the results instance variable of the receiver."

  | entryClass setClass tally aMethod anEntry tempDict aSender resultSet 
    rawCounts rawArray sample j depth k rcvrClass newObjClass |

  entryClass := Entry.
  setClass := EntrySet.
  results := Array new: 2 .

  "First get the absolute execution counts from the virtual machine"
  rawCounts := ProfMonitor _getMethodCounts .
  resultSet := setClass new.
  results at: 2 put: resultSet .
  1 to: rawCounts size by: 4 do: [ :j |
    aMethod := rawCounts at: j .
    tally := rawCounts at: j + 1 .

    "check class to filter out methods that have been garbage collected and reused"
    aMethod _class == GsMethod ifTrue:[ 
      anEntry := entryClass new.
      anEntry cmethod: aMethod; tally: tally .
      resultSet add: anEntry.
      ].
    ].
  rawCounts size: 0 .

  "Now process the statistical sample file."
  tempDict := IdentityKeyValueDictionary new .
  rawArray := self _readSampleFile.
  j := 1 .
  [j < rawArray size ] whileTrue:[
    sample := rawArray at: j .
    sample == SystemRepository ifTrue:[
       j := j + 1 . "skip header marker"
       sample := rawArray at: j .
       sample _isSmallInteger
          ifTrue:[ depth := sample.  j := j + 1 .  ].
    ]
    ifFalse:[
      aMethod := rawArray at: j .
      k := 1 .
      aMethod == true ifTrue:[ "an object creation sample"
	newObjClass := rawArray at: j + k . 
        newObjClass == nil ifFalse:[
          aSender := rawArray at: j + k + 1.
          rcvrClass := rawArray at: j + k + 2.
          anEntry := tempDict at: newObjClass otherwise: nil . 
          anEntry == nil
            ifTrue:[ anEntry := entryClass new cmethod: newObjClass; tally: 1 .
                     tempDict at: newObjClass put: anEntry ]
            ifFalse:[ anEntry tally: anEntry tally + 1 ].
          self forEntry: anEntry tallyRcvrClass: rcvrClass .
          self forEntry: anEntry tallySender: aSender .
          ].
        ]
      ifFalse:[ "a normal statistical method execution sample"
        (aMethod _class == GsMethod _or:[ aMethod == #GCI ]) ifTrue:[
          "method still exists or is a reenter marker"
          anEntry := tempDict at: aMethod otherwise: nil .
          anEntry == nil 
	    ifTrue:[ anEntry := entryClass new cmethod: aMethod ; tally: 1 .
		     tempDict at: aMethod put: anEntry ]
	    ifFalse:[ anEntry tally: anEntry tally + 1 ].
          depth > 1 ifTrue:[
            rcvrClass := rawArray at: j + k .
	    aSender := rawArray at: j + k + 1.  
            self forEntry: anEntry tallyRcvrClass: rcvrClass .
            self forEntry: anEntry tallySender: aSender .
	    ].
          ].
        ].
      j := j + (depth * 2).
      ].
    ]"whileTrue".

  resultSet := setClass new.
  results at: 1 put: resultSet .
  tempDict doValues:[:anEntry | | sendersSet rcvrClassesSet senders rcvrClasses|
    resultSet add: anEntry .

    sendersSet := setClass new .
    senders := anEntry senders .
    senders ~~ nil ifTrue:[
      senders doValues:[ :aSender | sendersSet add: aSender ]. 
      ].
    anEntry senders: sendersSet .

    rcvrClassesSet := setClass new .
    rcvrClasses := anEntry rcvrClasses .
    rcvrClasses ~~ nil ifTrue:[
      rcvrClasses doValues:[ :aRcvrCls | rcvrClassesSet add: aRcvrCls ]. 
      ].
    anEntry rcvrClasses: rcvrClassesSet .
    ].
  
%

category: 'Private'
method: ProfMonitor
initialize

"Private."

self initializeNoFile .
self _createFile: self class newProfileFileName .
file close .
%

category: 'Private'
method: ProfMonitor
initializeNoFile

"Private."

interval := self class defaultInterval .
sampleDepth := 2 .
traceObjCreation := false .
%

category: 'Monitoring'
method: ProfMonitor
monitorBlock: aBlock

"Similar to System | millisecondsToRun:, this method starts profiling,
 executes the block, and terminates profiling."

self startMonitoring.
aBlock value.
self stopMonitoring; gatherResults; removeFile
%

category: 'Updating'
method: ProfMonitor
traceObjectCreation: aBoolean

"Enable (aBoolean == true) or disable profiling of object creation.  The state
 change will take effect on the next invocation of ProfMonitor>>startMonitoring
 for the receiver."

aBoolean _validateClass: Boolean .
traceObjCreation := aBoolean .
sampleDepth < 2 ifTrue:[ sampleDepth := 2 ].
%

category: 'Monitoring'
method: ProfMonitor
profileOff

"Stop the given monitor and report."

self stopMonitoring; gatherResults; removeFile.
^ self reportDownTo: 1 .
%

! fix bug 11632
category: 'Updating'
method: ProfMonitor
removeFile

"Removes the file generated by profiling operations in this profile monitor,
 if the file still exists."

| fileName |
file ~~ nil ifTrue:[
  fileName := file pathName .
  file close .
  GsFile removeServerFile: fileName .
  file := nil .
  ].
%

category: 'Updating'
method: ProfMonitor
removeResults

"Releases results to aid garbage collection."

results ~~ nil ifTrue:[
  results size: 0 .
  results := nil .
  ].
self _removeSampleArray .
%

category: 'Reporting'
method: ProfMonitor
report

"Formats and returns a string holding a report of the receiver's most
 recent profile run."

^self reportDownTo: 1
%

category: 'Private'
method: ProfMonitor
_sendersReportDownTo: tally

""
"Report formatting is:
   % tally  class-and-method-name
       tally times sender was  sender-class-and-selector
       ....
       tally times receiver class was  className
       ... 
"

  | tallySet nameStr rpt lf nonrep nonreptallies total meths elapsedTime |
  tallySet := results at: 1 .
  nameStr := 'STATISTICAL METHOD SENDERS RESULTS' .
  rpt := String new .
  lf := Character lf.
  meths := tallySet sortDescending: 'tally'.
  (endTime >= startTime) ifTrue: [
    elapsedTime := endTime - startTime.
  ] ifFalse: [
    elapsedTime := endTime + (16rffffffff - startTime).
  ].
  rpt addAll: nameStr; add: lf ;
    addAll: 'elapsed CPU time:    '; 
         addAll: (elapsedTime) asString; addAll: ' ms'; add: lf .
   
  rpt addAll: 'monitoring interval: '; 
         addAll: interval asString; addAll: ' ms'; add: lf .

  rpt add: lf;
    addAll: '     %   tally  class and method name'; add: lf;
    addAll: '------  ------  --------------------------------------'; add: lf.
  total := 0.
  meths do: [:each | | aMeth |
    aMeth := each cmethod .
    (aMeth _class == GsMethod _or:[ aMeth == #GCI ]) ifTrue:[
      total := total + each tally.
      ]
  ].

  nonrep := 0.  "non reported methods (below tally threshold)"
  nonreptallies := 0.
  meths do: [:each | | aMeth |
    aMeth := each cmethod .
    (aMeth _class == GsMethod _or:[ aMeth == #GCI ]) ifTrue:[
      each tally < tally ifTrue: [
	nonrep := nonrep + 1.
	nonreptallies := nonreptallies + each tally.
      ]
      ifFalse:[  | senders rcvrClasses pct |
	rpt add: lf .
	pct := each tally asFloat * 100.0 / total.
	rpt addAll: (pct asStringUsingFormat: #(-5 1 false)); addAll: '%  ';
	    addAll: (each tally asString width: -6); addAll: '  '  .
        aMeth == #GCI 
           ifTrue:[ rpt addAll:(#GCI asString width: 12) ]
           ifFalse:[ rpt addAll: (aMeth _classAndSelectorNameWidth: 12)].
        rpt add: lf .

	senders := each senders sortAscending: 'tally' .
	rcvrClasses := each rcvrClasses sortAscending: 'tally' .

	senders do:[ :aSender | | senderMeth |
	  aSender tally > tally ifTrue:[
	    rpt addAll:'        ' ;
	        addAll: (aSender tally asString width: -6); 
                addAll:' times sender was          ' .

            senderMeth := aSender cmethod .
            senderMeth == #GCI
              ifTrue:[ rpt addAll:(#GCI asString width: 12) ]
	      ifFalse:[ rpt addAll:(senderMeth _classAndSelectorNameWidth: 12)].
	    rpt add: lf .
	    ].
	  ].

        (senders size > 0 _and:[ rcvrClasses size > 0] ) ifTrue:[
          rpt addAll:'           ------'; add: lf .
          ].

	rcvrClasses do:[ :aRcvrCls | | aClass |
	  aRcvrCls tally > tally ifTrue:[
	    rpt addAll:'        ' ;
	        addAll: (aRcvrCls tally asString width: -6); 
                addAll:' times receiver class was  ' .
            aClass := aRcvrCls cmethod .
	    rpt addAll: aClass name  ;
	        add: lf .
	    ].
	  ].

      rpt addAll: '-----------------------------'; add: lf.
      ].
    ].
  ].

  nonrep > 0 ifTrue: [ | pct |
    pct := nonreptallies asFloat * 100.0 / total.
    rpt addAll: (nonreptallies asString width: -6); addAll: '  ' ;
        addAll: (pct asStringUsingFormat: #(-6 2 false)); addAll: '   ';
        addAll: nonrep asString ; addAll: ' other methods'; add: lf
  ].

  "no total report line for this section."

  ^rpt
%

category: 'Private'
method: ProfMonitor
_objCreationReportDownTo: tally

""

  | tallySet nameStr rpt lf nonrep nonreptallies total meths |
  tallySet := results at: 1 .
  nameStr := 'OBJECT CREATION REPORT' .
  rpt := String new .
  lf := Character lf.
  meths := tallySet sortDescending: 'tally'.
  rpt addAll: nameStr; add: lf .

  rpt add: lf;
    addAll: ' tally  class of created object'; add: lf;
    addAll: '------  --------------------------------------'; add: lf.
  total := 0.
  meths do: [:each | | aMeth |
    aMeth := each cmethod .
    (aMeth _class == GsMethod _or:[ aMeth == #GCI ]) ifFalse:[
      total := total + each tally.
      ]
  ].

  nonrep := 0.  "non reported classes (below tally threshold)"
  nonreptallies := 0.
  meths do: [:each | | aMeth |
    aMeth := each cmethod .
    (aMeth _class == GsMethod _or:[ aMeth == #GCI ]) ifFalse:[
      each tally < tally ifTrue: [
	nonrep := nonrep + 1.
	nonreptallies := nonreptallies + each tally.
      ]
      ifFalse:[  | senders aClass |
        aClass := aMeth .
	rpt add: lf .
	rpt addAll: (each tally asString width: -6); addAll: '  ' ;
	    addAll: (aClass name asString width: 12) ; add: lf.

	senders := each senders sortAscending: 'tally' .
	senders do:[ :aSender | | senderMeth |
	  aSender tally > tally ifTrue:[
            rpt addAll: '   ';
	        addAll: (aSender tally asString width: -6); addAll:'  ' ;
                addAll: ' instances created by  ' .
            senderMeth := aSender cmethod .
            senderMeth == #GCI 
              ifTrue:[ rpt addAll:(#GCI asString width: 12) ]
              ifFalse:[ rpt addAll:(senderMeth _classAndSelectorNameWidth: 12)].
	    rpt add: lf .
	    ].
	  ].
      rpt addAll: '-----------------------------'; add: lf.
      ].
    ].
  ].

  nonrep > 0 ifTrue: [
    rpt addAll: (nonreptallies asString width: -6); addAll: '  ' ;
        addAll: nonrep asString ; addAll: ' objects of other classes'; add: lf
  ].

  ^rpt
%

category: 'Private'
method: ProfMonitor
_invocationCountReportDownTo: tally

"Gemstone64 v2.0 , invocation counts not supported"

^ 'METHOD INVOCATION COUNTS - not implemented in this release' + Character lf
%
! For bug 34258 in Gs64 v2.0 comment out old implementation  .
! To be resurrected in future v2.x release
!   | rpt lf nonrep nonreptallies meths nameStr tallySet |
! 
!   nameStr := 'METHOD INVOCATION COUNTS' .
!   tallySet := results at: 2 .
!   rpt := String new .
!   lf := Character lf.
!   meths := tallySet sortDescending: 'tally'.
!   rpt addAll: nameStr; add: lf .
! 
!   rpt add: lf;
!     addAll: ' tally  class and method name'; add: lf;
!     addAll: '------  --------------------------------------'; add: lf.
! 
!   nonrep := 0.  "non reported methods (below tally threshold."
!   nonreptallies := 0.
!   meths do: [:each |
!     each tally < tally ifTrue: [
!       nonrep := nonrep + 1.
!       nonreptallies := nonreptallies + each tally.
!     ]
!     ifFalse: [ 
!       rpt addAll: (each tally asString width: -6); addAll: '  ' ;
!           addAll: (each cmethod _classAndSelectorNameWidth: 25) ; add: lf.
!     ].
!   ].
! 
!   ^rpt
! %

category: 'Private'
method: ProfMonitor
_samplingReportDownTo: tally

""

  | rpt lf nonrep nonreptallies total ave meths tallySet nameStr
    elapsedTime |

  tallySet := results at: 1 .
  nameStr := 'STATISTICAL SAMPLING RESULTS' .
  rpt := String new .
  lf := Character lf.
  meths := tallySet sortDescending: 'tally'.

  (endTime >= startTime) ifTrue: [
    elapsedTime := endTime - startTime.
  ] ifFalse: [
    elapsedTime := endTime + (16rffffffff - startTime).
  ].
  rpt addAll: nameStr; add: lf ;
    addAll: 'elapsed CPU time:    '; 
         addAll: (elapsedTime) asString; addAll: ' ms'; add: lf .
   
  rpt addAll: 'monitoring interval: '; 
         addAll: interval asString; addAll: ' ms'; add: lf .

  rpt add: lf;
    addAll: ' tally       %   class and method name'; add: lf;
    addAll: '------   -----   --------------------------------------'; add: lf.
  total := 0.
  meths do: [:each |
    each cmethod class == GsMethod ifTrue:[
      total := total + each tally.
      ].
  ].

  nonrep := 0.  "non reported methods (below tally threshold."
  nonreptallies := 0.
  meths do: [:each |
    each cmethod class == GsMethod ifTrue:[
      each tally < tally ifTrue: [
	nonrep := nonrep + 1.
	nonreptallies := nonreptallies + each tally.
      ]
      ifFalse: [ | pct |
	pct := each tally asFloat * 100.0 / total.
	rpt addAll: (each tally asString width: -6); addAll: '  ' ;
	    addAll: (pct asStringUsingFormat: #(-6 2 false)); addAll: '   ';
	    addAll: (each cmethod _classAndSelectorNameWidth: 25) ; add: lf.
      ].
    ].
  ].

  nonrep > 0 ifTrue: [ | pct |
    pct := nonreptallies asFloat * 100.0 / total.
    rpt addAll: (nonreptallies asString width: -6); addAll: '  ' ;
        addAll: (pct asStringUsingFormat: #(-6 2 false)); addAll: '   ';
        addAll: nonrep asString ; addAll: ' other methods'; add: lf
  ].

  ave := total // (meths size max: 1).
  rpt addAll: (total asString width: -6); addAll: '  100.00   ';
    addAll: 'Total';
    add: lf.
  ^rpt
%

category: 'Reporting'
method: ProfMonitor
reportDownTo: tally

"Formats and returns a string holding a report of the receiver's most recent
 profile run.  Stops reporting when a tally smaller than tally is
 encountered."

  | rpt lf aReport |

  results == nil ifTrue: [^'No profiling data are available.'].
  
  lf := Character lf.
  rpt := String new .
  aReport := self _samplingReportDownTo: tally  .
  rpt addAll: aReport;  add: lf ; add: lf .
  aReport size: 0 . 

  aReport := self _sendersReportDownTo: tally . 
  rpt addAll: aReport;  add: lf ; add: lf .
  aReport size: 0 . 

  traceObjCreation ifTrue:[  
    aReport := self _objCreationReportDownTo: tally .
    rpt addAll: aReport;  add: lf ; add: lf .
    aReport size: 0 .
    ]
  ifFalse:[ rpt addAll:'OBJECT CREATION PROFILING Not Enabled'; 
		add: lf ; add: lf .
    ].

  aReport := self _invocationCountReportDownTo: tally .
  rpt addAll: aReport;  add: lf .
  aReport size: 0 . 

  ^ rpt
%

category: 'Accessing'
method: ProfMonitor
results

"Returns the value of the instance variable results."

^results
%

category: 'Updating'
method: ProfMonitor
results: newValue

"Modify the value of the instance variable results."

results:= newValue
%

category: 'Monitoring'
method: ProfMonitor
startMonitoring

"Starts monitoring."

self _openFileAppend .
self _zeroArgPrim: 1 .  "enable monitoring in the virtual machine"
startTime := System _readClock.
%

category: 'Monitoring'
method: ProfMonitor
stopMonitoring

"Stops monitoring."

endTime := System _readClock.
self _zeroArgPrim: 2  . "stop monitoring in the virtual machine"
file close.
%

category: 'Private'
method: ProfMonitor
_removeSampleArray

"Releases the sample Array from the export set and dereferences it."

rawSampleArray ~~ nil ifTrue:[
  rawSampleArray size: 0 .
  self _zeroArgPrim: 4 .
  rawSampleArray := nil .
  ].
%

category: 'Private'
method: ProfMonitor
_readSampleFile

"Returns an Array for use by reporting methods.  The Array is of the form:

    aSmallInteger - depth of sampling for next section of Array,
    aGsMethod,  ..., aGsMethod   - methods and senders 
    aSmallInteger - depth of sampling for next section of Array,
    aGsMethod, ... , aGsMethod  - methods and senders 

 For each method it is followed by depth - 1  calling methods."

"The result Array is put into the exportSet to keep GsMethods alive,
 since these method references were reconstructed from the external
 sample file."

self _openFileRead.
rawSampleArray := self _zeroArgPrim: 3.
file close.
^ rawSampleArray
%

category: 'Private'
method: ProfMonitor
_zeroArgPrim: opcode

"opcode      function
   1		start profiling
   2		stop profiling
   3            read sample file
   4            release sample Array
"

<primitive: 191>
self _primitiveFailed: #_zeroArgPrim:
%

! initialize the class
run
ProfMonitor _reinitialize .
^ true
%

