Announcement

Collapse

Forum Guidelines

This forum is for finished source code that is working properly. If you have questions about this or any other source code, please post it in one of the Discussion Forums, not here.
See more
See less

Another Profiler Creator Function

Collapse
X
 
  • Filter
  • Time
  • Show
Clear All
new posts

  • Another Profiler Creator Function

    Yes, another Profile Creator Function. This is a bit like the joke about London buses - you wait for ages for one to turn up and then two turn up.

    There is a similarity between the code here and the code here; ie Gösta H. Lovgren-2's entry in the Source Code forum. This shouldn't be a surprise to anyone keeping up with the proceedings here; where Gösta's code was, and still is, being developed. Some of my work found it's way into Gösta's and some of Gösta's code found it's way into mine.

    The approaches differ in that Gösta's code is more string oriented and mine is more array oriented although both use Array Sort. Some procedures need to be excluded and I chose an exclusion list whereas Gösta chose to scan the Win32API.inc file which takes longer but has the merit that a change in Win32API.inc may require my list to be updated - no more further ado is needed with Gösta's approach. Another difference is the UDT elements are sorted as found in my case whereas with Gösta's approach the elements are effectively transferred to the primary element as that is how arrays of UDTs are sorted pre PB9/CC5. So, Gösta's code will work with pre PB9/CC5, unless Gösta is using PB9/CC5 'stuff' that I haven't spotted, whereas mine will not.

    Gösta is now tracking variables and so on. This is not a line that I want to pursue.

    The example in the PB doc intrigued me. The Profiles output is:

    MySubA, 1, 11016
    MySubB, 100, 10014

    We cannot tell whether MySubA and MySubB are called separately of if MySubA calls MySubB. The PB Docs suggest that at first glance, MySubA may be 'bottlenecking'. The Docs go on to say "However, if MuSubB is actually called by MySubA, the results need to be assessed differently.

    To distinguish programmatically we'd need to profile each and every procedure which calls one or more procedures and that is what I've done and called the approach, wait for it, Extended Profiling.

    I wrote a small piece of code to emulate the above example and got MySubA to call MySubB. Part of the standard profile gave:
    Code:
     In time used order:
     
                        Calls      Tot ms     ms/call     %
     
      1) MySubA             1       11937       11937   52.2%
      2) MySubB           100       10937         109   47.8%
    which is very similar to the example.

    The extended profile gives:
    Code:
     *** Extended profile ***
     
     MYSUBA 11937
     
       MySubB       100 x 109 = 10937 [91.6%]
     
     PBMAIN 11921
     
       MySubA       1 x 11937 = 11937 [100.1%]
    Two things first: 100 x 109 = 10937, ie 100 calls at 109 ms/call <> 10937, but the right hand side is accurate. The program does not output parts of a millisecond so that 109 is a truncated 10937/100 ie ms/call. MySubA seems to take longer than PBMain. PBMain is not profiled by the Profile statement so the program takes a stab at it avoiding the calculation until it has to do so. The Timer statement is used and that is only accurate to 10ms anyway. These little anomalies have no real bearing on the analysis.

    It is clear from the extended profile that MySubA calls MySubB and MySubB takes up over 90% of MySubA's time.

    Here is the profile of another little app:
    Code:
     In time used order:
     
                           Calls      Tot ms     ms/call     %
     
      1) ProcOne               2       13468        6734   35.7%
      2) ProcThree            39       12187         312   32.3%
      3) ProcTwo               9       12094        1343   32.0%
    This was deliberately contrived to give similar %.

    If any procedure was reduced by 10% then the app would take a little over one second less time to complete. The question is can any procedure be reduced by 10%.

    This is the extended profile.
    Code:
     *** Extended profile ***
     
     PBMAIN 17218
     
       ProcOne         2 x 6734 = 13468 [78.2%]
       ProcThree       6 x 312 = 1874 [10.9%]
       ProcTwo         1 x 1343 = 1343 [7.8%]
     
     PROCONE 13468
     
       ProcThree       6 x 312 = 1874 [13.9%]
       ProcTwo         8 x 1343 = 10750 [79.8%]
     
     PROCTWO 12094
     
       ProcThree       27 x 312 = 8437 [69.8%]
    The bulk of PBMain's time is takn up by ProcOne. Just less than 94% of ProcOne's time is taken up outside so there is little chance of getting a 10%, or anything like it, reduction there.

    Nearly 70% of ProcTwo is spent in ProcThree so there is some room to work on ProcTwo but we may still have a struggle.

    ProcThree isn't listed because it doesn't call anything.

    ProcThree should be our target.

    Notice, for example, in the above that ProcThree gets mentioned three times - 6, 6 and 27 giving 39 as in the standard profile above.

    We could get there without the extended profile but this is a simple example. How about 50 or 60 procedures calling other procedures with cross calling?

    There is no such thing as a free lunch, so they say, and that applies here too. Too get extended profiling we have to get our hands dirty.

    As with my earlier code, and with Gösta's code, we have to add to the head and tail of PBmain.

    In addition, before each and every procedure call we have to insert 'Egress("procedure_name")' where procedure_name is, of course, what ever the procedure name is.

    This is how the last example looks.

    Code:
    #Compile Exe
    #Dim All
     
    #Include "ProfileReportDR.inc"
     
    Function PBMain()
     
    ' Added to PBMain ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
      Local Profile_Start_Time As Long
      Profile_Start_Time = Timer
      lMaxSize = 999
      ReDim ThisProfile( 0 To lMaxSize ) As ExtendedProfile
      Local i As Long
      For i = 0 To lMaxSize
        ThisProfile(i).Caller = "~"
        Thisprofile(i).Called = "~"
      Next
     
    '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
     
      Sleep 1000
      Egress("ProcOne")
      Call ProcOne
      For i = 1 To 6
        Egress("ProcThree")
        Call ProcThree
      next
      Egress("ProcOne")
      Call ProcOne
      Egress("ProcTwo")
      Call ProcTwo
     
      ' Added to PBMain
      Profile_Ordered(Profile_Start_Time )
     
      MsgBox "Done"
     
    End Function
     
    Sub ProcOne
    Local i As Long
     
      Sleep 420
      For i = 1 To 4
        Egress("ProcTwo")
        Call ProcTwo
      Next
      For i = 1 To 3
        Egress("ProcThree")
        Call ProcThree
      Next
     
    End Sub
     
    Sub ProcTwo
    Local i As Long
     
      Sleep 400
      For i = 1 To 3
        Egress("ProcThree")
        Call ProcThree
      Next
     
    End Sub
     
    Sub ProcThree
     
      Sleep 300
     
    End Sub
    The Profile statement outputs in upper-case. The extended profiler is case sensitive and procedure_name will override the Profile output. I mentioned that Egress has to be inserted before each and every procedure call. This is best practice but if a particular procedure's use was bypassed on all occasions then it would not appear in the extended profile. It would have no bearing on the remaining figures. If a procedure call took 10% of the time of it's 'parent' procedure then it would, obviously, still be 10% whether a 'sibling' procedure is profiled or not.

    "ProfileReportDR.inc" is in the next post.

    Comments are appreciated and may be made here.

    Added: If Egress was not used at all then the output would simply be the standard one.
    Last edited by David Roberts; 21 Nov 2008, 01:52 PM. Reason: Mentioned non-use of Egress.

  • #2
    ProfileReportDR.inc

    Added: Each procedure Call/Called pair takes up one element of ThisProfile(). Initially 1000 elements are provided via lMaxSize - that should keep most of you quiet. If more are required then blocks of 500 elements are added. The UDT takes up 154 bytes so 1000 of them is only about 150KB. My first approach which produced exactly the same output was a tad more RAm greedy. I have 2GB on board and ran out of memory when tested on the 'Life' program.

    Code:
    '-------------------------------------------------------
    '  At the top of PBMain put the following lines:
    '
    '  Local Profile_Start_Time As Long
    '  Profile_Start_Time = Timer
    '  lMaxSize = 999
    '  ReDim ThisProfile( 0 To lMaxSize ) As ExtendedProfile
    '  Local i As Long
    '  For i = 0 To lMaxSize
    '    ThisProfile(i).Caller = "~"
    '    Thisprofile(i).Called = "~"
    '  Next
    '
    ' At the bottom of PBMain put this line:
    ' Profile_Ordered(Profile_Start_Time)
    '-------------------------------------------------------
    
    ' For extended profiing ---------------
    Type ExtendedProfile
      Caller As String * 50
      Called As String * 50
      UCalled As String * 50
      NumCalled As Long
    End Type
    Global ThisProfile() As ExtendedProfile
    Global lMaxSize, lProcCtr As Long
    '--------------------------------------
    
    Type ProfileMetrics
      Procedure As String * 50
      Calls As Long
      Time As Long
      TimePerCall As Single
      Percentage As Single
    End Type
    
    Macro Egress(prm)
      UpDateExProfile( FuncName$, prm )
    End Macro
    
    Function UpdateExProfile(FromProc As String, ToProc As String ) As Long
    Local i As Long, sTemp0, sTemp1 As String
    
    i = 0
      Do
        stemp0 = Trim$( ThisProfile(i).Caller )
        If sTemp0 = "~" Then
          ThisProfile(i).Caller = FromProc
          ThisProfile(i).UCalled = UCase$(ToProc)
          ThisProfile(i).Called = ToProc
          ThisProfile(i).NumCalled = 1
          Exit Loop
        Else
          If sTemp0 = FromProc Then
            sTemp1 = Trim$(ThisProfile(i).UCalled)
            If sTemp1 = "~" Then
              ThisProfile(i).UCalled = UCase$(ToProc)
              ThisProfile(i).Called = ToProc
              ThisProfile(i).NumCalled = 1
              Exit Loop
            Else
              If sTemp1 = UCase$(ToProc) Then
                Incr ThisProfile(i).NumCalled
                Exit Loop
              End If
            End If
          End If
        End If
        Incr i
        If i > lMaxSize Then
          lMaxSize = lMaxSize + 500
          ReDim Preserve ThisProfile( 0 To lMaxSize )
        End If
      Loop
      
    End Function 
    
    Function FillArray( ArrayEx() As String ) As Long
    Local x  As Long
    
    	ReDim ArrayEx( 1 To DataCount ) As String
    	
    	For x = 1 To DataCount
    		ArrayEx( x ) = Read$( x )
      Next
    
    	Function = DataCount
    	
    	' Exclusion list
    	Data "CREATEDIALOG"
      Data "CREATEDIALOGINDIRECT"
      Data "CMYK"
      Data "COPYMEMORY"
      Data "CREATEWINDOW"
      Data "DIALOGBOX"
      Data "DIALOGBOXINDIRECT"
      Data "FILLMEMORY"
      Data "FAILED"
      Data "GETNEXTWINDOW"
      Data "GETYVALUE"
      Data "GETHINST"
      Data "GETBVALUE"
      Data "GETGVALUE"
      Data "GETRVALUE"
      Data "GETMVALUE"
      Data "GETCVALUE"
      Data "GETKVALUE"
      Data "HRESULT_SEVERITY"
      Data "HRESULT_FACILITY"
      Data "HRESULT_FROM_WIN32"
      Data "HRESULT_CODE"
      Data "HRESULT_FROM_NT"
      Data "HRESULT_FROM_SETUPAPI"
      Data "IS_ERROR"
      Data "MAKE_SCODE"
      Data "MAKE_HRESULT"
      Data "MOVETO"
      Data "MAKELANGID"
      Data "MAKEROP4"
      Data "PALETTERGB"
      Data "PALETTEINDEX"
      Data "SCODE_CODE"
      Data "SCODE_SEVERITY"
      Data "SUCCEEDED"
      Data "SCODE_FACILITY"
      Data "ZEROMEMORY"
      Data "PBMAIN"
      Data "UPDATEEXPROFILE"
      Data "FILLARRAY"
      Data "PROFILE_ORDERED"
      Data "CALLSSORT"
      Data "TIMESORT"
    	
    End Function
    
    Function CallsSort(Param1 As ProfileMetrics, Param2 As ProfileMetrics) As Long
      If Param1.Calls < Param2.Calls Then
        Function = +1 : Exit Function
      End If
      If Param1.Calls > Param2.Calls Then
        Function = -1 : Exit Function
      End If
      If Param1.Procedure < Param2.Procedure Then
        Function = -1 : Exit Function
      End If
      If Param1.Procedure > Param2.Procedure Then
        Function = +1 : Exit Function
      End If
    End Function
    
    Function TimeSort(Param1 As ProfileMetrics, Param2 As ProfileMetrics) As Long
      If Param1.Time < Param2.Time Then
        Function = +1 : Exit Function
      End If
      If Param1.Time > Param2.Time Then
        Function = -1 : Exit Function
      End If
      If Param1.Procedure < Param2.Procedure Then
        Function = -1 : Exit Function
      End If
      If Param1.Procedure > Param2.Procedure Then
        Function = +1 : Exit Function
      End If
    End Function
    
    Function Profile_Ordered(Profile_Start_Time As Long) As Long
    
      Local sInput, sTemp0, sTemp1, Uncalled As String
      Local fnum, lLineCtr, lUncalledCtr, accepted, i, j, found, lhrs, lmins, lsecs, longest, lTemp0, lTemp1 As Long, tot As Double
      Local PBMainTime As Single
      Dim Transfer( 1 To 3 ) As String
      Dim UnusedProc() As String
      Local Profile_FileName As String
      
      Local NoOfExclusions As Long
      ReDim Exclusions( 0 ) As String
      NoOfExclusions = FillArray( Exclusions() )
       
      Profile_FileName = CurDir$ & "\" & _ 'Exe.Path$ only returns 8 char Dos names so use CurDir$
                           Exe.Name$ & _ 'Progran running name
                           "_Profile.txt" 'Add a unique identifier to it
      
      Profile Profile_FileName 'create the file
      fnum = FreeFile
    
    retry:
      Try
        Open Profile_FileName For Input As #fnum
      Catch 
        Sleep 100
        GoTo retry
      End Try
      
      FileScan #fnum, Records To lLineCtr ' Get the number of lines
      Dim ProfileData( 1 To lLineCtr ) As ProfileMetrics  ' Create max array of UDTs
      
      For i = 1 To lLineCtr
        Line Input #fnum, sInput
        Parse sInput, Transfer() ' Put line into a holding array
        j = Val(Transfer(2))     ' ie Number of calls
        sTemp0 = UCase$(Transfer(1)) ' ie Procedure name
        Array Scan Exclusions(), = sTemp0, To found
        If IsFalse(found) Then
          sTemp0 = MCase$(Transfer(1)) ' I hate all CAPS as well <smile>
          If j <> 0 Then ' accept for analysis
            Incr accepted
            ProfileData(accepted).Procedure = sTemp0 ' and now transfer data to UDTs
            ProfileData(accepted).Calls = j
            ProfileData(accepted).Time = Val(Transfer(3)) ' ie Time spent
            ProfileData(accepted).TimePerCall = Val(Transfer(3))/j
          Else
            ' Put uncalled procedures into a string - we'll separate them later
            Uncalled = Build$(Uncalled, sTemp0, $CrLf)
          End If
        End If
      Next
      Close #fnum
      
      ReDim Preserve ProfileData( 1 To accepted ) ' Trim the array of UDTs to the lines we accepted
      
      ' Uncalled has a terminating $CrLF which will give an excessive procedure count when parsing later
      Uncalled = RTrim$(Uncalled, $CrLf)
      
      ' Calculate percentage times
      For i = 1 To accepted
        tot = tot + ProfileData(i).Time
      Next
      For i = 1 To accepted
        ProfileData(i).Percentage = Round(ProfileData(i).Time/tot, 3)*100
      Next
      
      ' Find the longest procedure name
      For i = 1 To accepted
        j = Len( Trim$(ProfileData(i).Procedure) )
        If j > longest Then longest = j
      Next
      Let longest = longest + 6 ' bit of elbow room
    
      If IsFile(Profile_FileName) Then Kill Profile_FileName
        
      Open Profile_FileName For Output As #fnum
           
        lhrs = Profile_Start_Time \ 3600
        lmins = (Profile_Start_Time  - (lhrs * 3600)) \ 60
        lsecs = (Profile_Start_Time -  (lhrs * 3600)) - (lmins * 60)
     
        Print #fnum, " Profile for " &  Profile_FileName 
        Print #fnum, " " + Date$ & "    Ran from " & _
                   Using$("##:##:## to ", lhrs, lmins, lsecs) & _
                   Time$ & _
                   Using$(" for #, seconds", Timer - Profile_Start_Time)
        
        ' How much of ThisProfile() did we use?
        lProcCtr = 0
        Do While ThisProfile(lProcCtr).NumCalled <> 0
          Incr lProcCtr
        Loop
        If lProcCtr > 0 Then
          ReDim Preserve Thisprofile( 0 To lProcCtr - 1 )
          ' Get the called procedures - they should be in mixed case
          ' We do this to avoid the uppercase that Funcname$ produces
          Dim CalledProcedures( 1 To lProcCtr ) As String
          For i = 0 To lProcCtr - 1
            CalledProcedures(i+1)= ThisProfile(i).Called
          Next
        End If
        
        Print #fnum: Print #fnum, " Alphabetical by Procedure Name:": Print #fnum
        Array Sort ProfileData() ' ie procedures
        GoSub PrintSort
        
        Print #fnum: Print #fnum, " In call frequency order:": Print #fnum
        Array Sort ProfileData(), Using CallsSort
        GoSub PrintSort
                  
        Print #fnum: Print #fnum, " In time used order:": Print #fnum
        Array Sort ProfileData(), Using TimeSort
        GoSub PrintSort
           
        ' Now list the uncalled procedures, if any
        If Uncalled <> "" Then
          Print #fnum
          Print #fnum, " Uncalled procedures:": Print #fnum
          ' How many are there?
          lUncalledCtr = ParseCount(Uncalled, $CrLf)
          ReDim UnusedProc( 1 To lUncalledCtr )
          ' Break string built early and fill array
          Parse Uncalled, UnusedProc(), $CrLf
          Array Sort UnusedProc()
          ' and now print them, spread over the page
          lTemp0 = Len( UnusedProc(1) ) + 2 ' for comma & space
          Print #fnum, UnusedProc(1);
          For i = 2 To lUncalledCtr
            Print #fnum, ", ";
            lTemp0 = lTemp0 + Len( UnusedProc(i) ) + 2
            If lTemp0 > 72 Then
              Print #1
              lTemp0 = Len( UnusedProc(i) ) + 2
            End If
            Print #fnum, UnusedProc(i);
          Next
        End If
        
        ' Extended profiling
        If lProcCtr > 0 Then
          Array Sort ThisProfile()
          Print #fnum: Print #fnum
          Print #fnum, " *** Extended profile ***"
          
          ' Build an uppercase version of ProfileData().Procedure
          ReDim ProcUName( 1 To accepted ) As String
          For i = 1 To accepted
            ProcUName(i) = UCase$( ProfileData(i).Procedure )
          Next
          
          ' PBMain is not profiled so use the following - not perfect, but not bad
          PBMainTime = (Timer - Profile_Start_Time)*1000
          
          i = 0
          sTemp1 = ""
          Do
            ' ThisProfile().Caller is uppercase by virtue of FuncName$, therefore sTemp0 is also
            sTemp0 = ThisProfile(i).Caller ' get calling procdure
            If sTemp0 <> sTemp1 Then ' is this different to the last calling procedure
              Print #fnum
              ' Get total time spent by calling procedure
              If Trim$(sTemp0) = "PBMAIN" Then 
                Print #fnum, " PBMAIN" + Str$(PBMainTime): Print #fnum
              Else
                ' ProcUName() is uppercase as defined above
                ' Scanning ProcUName avoids using 'Collate Ucase'
                Array Scan ProcUName(), = sTemp0, To found
                lTemp0 = ProfileData(found).Time
                Print #fnum, " " + Trim$(sTemp0) + Str$(lTemp0): Print #fnum
              End If
            End If
            ' ThisProfile().UCalled is uppercase as written, required in the
            ' building of ThisProfile(), therefore sTemp1 is also
            sTemp1 = ThisProfile(i).UCalled ' get called procedure
            ' ProcUName() is uppercase as defined above
            ' Scanning ProcUName avoids using 'Collate Ucase'
            Array Scan ProcUName(), = sTemp1, To found ' find it in our accepted list
            ' Calculate total time spent by called procedure in calling procedure
            lTemp1 = Int( ThisProfile(i).NumCalled*ProfileData(found).TimePerCall ) 
            ' Build output
            sTemp1 = Trim$(ThisProfile(i).Called) ' get rid of those chr$(0)
            sTemp1 = sTemp1 + Space$(longest - Len(sTemp1)) + Str$(ThisProfile(i).NumCalled) + " x" + _
              Str$( Int( ProfileData(found).TimePerCall ) ) + " =" + Str$(lTemp1) + " ["
            If Trim$(sTemp0) = "PBMAIN" Then
              Print #fnum, "   " + sTemp1 + Trim$(Str$( Round( lTemp1*100/PBMainTime, 1 ) )) + "%" +"]"
            Else
              Print #fnum, "   " + sTemp1 + Trim$(Str$( Round( lTemp1*100/lTemp0,1 ) )) + "%" + "]"
            End If
            sTemp1 = Stemp0 ' Copy last calling procedure
            Incr i                                                                                            
          Loop Until i = lProcCtr
        End If
        ' End of Extended profiling
                      
      Close #fnum
      
      Exit Function
      
    PrintSort:
      Print #fnum, Space$(8 + longest);"Calls      Tot ms     ms/call     %": Print #fnum  
      For i = 1 To accepted
        If lProcCtr > 0 Then
          ' We need to be careful here
          ' If any procedures have not been included in the extended profile then they will
          ' not be in CalledProcedures() and will output, by default, in leading character uppercase format.
          Array Scan CalledProcedures(), Collate UCase, = ProfileData(i).Procedure, To found
          If found Then
            sTemp0 = Trim$(CalledProcedures(found))
          Else
            sTemp0 = Trim$(ProfileData(i).Procedure)
          End If
        Else
          sTemp0 = Trim$(ProfileData(i).Procedure)
        End If
        Print #fnum, Using$("###",i);") ";sTemp0;Space$(longest - Len(sTemp0));Using$("########", ProfileData(i).Calls); _
        Using$("############", ProfileData(i).Time);Using$("############", Int( ProfileData(i).TimePerCall) );Using$("   ##.#", ProfileData(i).Percentage);"%"
      Next
      Return
    
    End Function
    Last edited by David Roberts; 21 Nov 2008, 04:54 AM. Reason: Notes on lMaxSize

    Comment


    • #3
      In the second example above we had
      Code:
      PROCONE 13468
       
        ProcThree       6 x 312 = 1874 [13.9%]
        ProcTwo         8 x 1343 = 10750 [79.8%]
      We can interpret this as: Of the 13468ms that ProcOne was active it lost focus for 12624ms ( from 1874 + 10750 ) whilst ProcTwo and ProcThree were being processed. In other words the program counter was not in ProcOne for 12624ms. During this time ProcOne had no influence on the application session time. It was influential then for 844ms ( from 13468 - 12624 ). We could refer to this as the procedure's focus code. If we divide this value by the application session time of 17218ms we get 0.049. We could say, then that ProcOne has a 4.9% influence on the application session time.

      A procedure which does nothing else but call a few other procedures has then a 0% influence. A procedure which does not call any other procedures will then have a % influence of its session time, or active time, divided by the application session time.

      If we add all the % influences of the procedures which call other procedures with those which do not and the % influence of PBMain then the total will be 100%.

      The procedure which has the greatest % influence will have the geatest potential for reducing the application session time.

      I have taken a leaf out of Microsoft's book with regard its use of 'Ex' with some APIs and renamed ProfileReport.inc to simply ProfileEx.inc.

      ProfileEx.inc incorporates the above analysis.

      If we return to the first example above where we concluded that MySubB warranted inspection and used ProfileEx.inc we get:

      Code:
      MYSUBA 11938 8.4% Influence
       
         MySubB       100 x 109 = 10937 [91.6%]
       
       PBMAIN 11943 0% Influence
       
         MySubA       1 x 11938 = 11938 [100%]
       
       MYSUBB 10938 91.6% Influence
      There is no doubting here that MySubB should be the target. Notice that PBMain has a zero % influence - it does nothing other than call MySubA.

      In the second example above it was felt that "there is some room to work on ProcTwo but we may still have a struggle" and "ProcThree should be our target".

      The ouput on applying ProfileEx is:

      Code:
      PBMAIN 17693 5.7% Influence
       
         ProcOne         2 x 6734 = 13469 [76.1%]
         ProcThree       6 x 312 = 1875 [10.6%]
         ProcTwo         1 x 1343 = 1343 [7.6%]
       
       PROCONE 13469 4.8% Influence
       
         ProcThree       6 x 312 = 1875 [13.9%]
         ProcTwo         8 x 1343 = 10750 [79.8%]
       
       PROCTWO 12094 20.7% Influence
       
         ProcThree       27 x 312 = 8437 [69.8%]
       
       PROCTHREE 12188 68.9% Influence
      This vindicates our conclusion and shows that ProcThree is over three times more influential than ProcTwo.

      The output of ProfileEx is effectively a list of recommendations.

      ProfileEx was then let loose on Gary Barnes' Life program as adapted by Gösta H. Lovgren-2 and allowed to run for 50 minutes.

      PBs Profile does not profile PBMain but ProfileEx does.

      Header_Print, which is called by Header_Set, had a % influence of 0.1%. All the other procedures failed to register at the printed resolution. PBMain had a 99.8% influence.

      I'll repeat that: 99.8%!

      It is clear then that we should be looking at PBMain and not the procedures.

      This could take some time. However, 'suspect' sections could be converted to procedures - ProfileEx would then profile them as standalone procedures with 100% 'focus' code. It may be illuminating when the sections % influences are printed since they will be part of PBMain's 99.8%.

      Suppose we have a procedure with a 60% influence and we were able to reduce its 'focus' code by 20% then the application session time will reduce by 12%.

      In the last example ProcThree has a Sleep for 300ms. If this was halved then we can expect a reduction in the application session time of 68.9%/2 ie 34.45%. The session time fell from 17693 to 11598 ie 34.45% exactly as predicted.

      We have then a tool whereby given a reduction in focus code we can determine very accurately the reduction in the application session time without actually running the application.

      Most of the changes have taken place in the 'Extended profiling' section but since other areas have been 'tweaked' ProfieEx.inc is in the next post.

      Other 'tweaking' areas have been spotted but they shouldn't impact very much. In particular, I want to rank in order of % influence.

      Added: I forgot to mention that ProfileEx outputs to NotePad as well as file.
      Last edited by David Roberts; 24 Nov 2008, 06:37 AM.

      Comment


      • #4
        ProfileEx.inc

        Code:
        '-------------------------------------------------------
        '  At the top of PBMain put the following lines:
        '
        '  Local Profile_Start_Time As Long
        '  Profile_Start_Time = Timer
        '  lMaxSize = 999
        '  ReDim ThisProfile( 0 To lMaxSize ) As ExtendedProfile
        '  Local i As Long
        '  For i = 0 To lMaxSize
        '    ThisProfile(i).Caller = "~"
        '    Thisprofile(i).Called = "~"
        '  Next
        '
        ' At the bottom of PBMain put this line:
        ' Profile_Ordered(Profile_Start_Time)
        '-------------------------------------------------------
        
        ' For extended profiing ---------------
        Type ExtendedProfile
          Caller As String * 50
          Called As String * 50
          Ucalled As String * 50
          NumCalled As Long
        End Type
        Global ThisProfile() As ExtendedProfile
        Global lMaxSize, lProcCtr As Long
        '--------------------------------------
        
        Type ProfileMetrics
          Procedure As String * 50
          Calls As Long
          Time As Long
          TimePerCall As Single
          Percentage As Single
        End Type
        
        Macro Egress(prm)
          UpDateExProfile( FuncName$, prm )
        End Macro
        
        Function UpdateExProfile(FromProc As String, ToProc As String ) As Long
        Local i As Long, sTemp0, sTemp1 As String
        
        i = 0
          Do
            stemp0 = Trim$( ThisProfile(i).Caller )
            If sTemp0 = "~" Then
              ThisProfile(i).Caller = FromProc
              ThisProfile(i).UCalled = UCase$(ToProc)
              ThisProfile(i).Called = ToProc
              ThisProfile(i).NumCalled = 1
              Exit Loop
            Else
              If sTemp0 = FromProc Then
                sTemp1 = Trim$(ThisProfile(i).UCalled)
                If sTemp1 = "~" Then
                  ThisProfile(i).UCalled = UCase$(ToProc)
                  ThisProfile(i).Called = ToProc
                  ThisProfile(i).NumCalled = 1
                  Exit Loop
                Else
                  If sTemp1 = UCase$(ToProc) Then
                    Incr ThisProfile(i).NumCalled
                    Exit Loop
                  End If
                End If
              End If
            End If
            Incr i
            If i > lMaxSize Then
              lMaxSize = lMaxSize + 500
              ReDim Preserve ThisProfile( 0 To lMaxSize )
            End If
          Loop
          
        End Function 
        
        Function FillArray( ArrayEx() As String ) As Long
        Local x  As Long
        
        	ReDim ArrayEx( 1 To DataCount ) As String
        	
        	For x = 1 To DataCount
        		ArrayEx( x ) = Read$( x )
          Next
        
        	Function = DataCount
        	
        	' Exclusion list
        	Data "CREATEDIALOG"
          Data "CREATEDIALOGINDIRECT"
          Data "CMYK"
          Data "COPYMEMORY"
          Data "CREATEWINDOW"
          Data "DIALOGBOX"
          Data "DIALOGBOXINDIRECT"
          Data "FILLMEMORY"
          Data "FAILED"
          Data "GETNEXTWINDOW"
          Data "GETYVALUE"
          Data "GETHINST"
          Data "GETBVALUE"
          Data "GETGVALUE"
          Data "GETRVALUE"
          Data "GETMVALUE"
          Data "GETCVALUE"
          Data "GETKVALUE"
          Data "HRESULT_SEVERITY"
          Data "HRESULT_FACILITY"
          Data "HRESULT_FROM_WIN32"
          Data "HRESULT_CODE"
          Data "HRESULT_FROM_NT"
          Data "HRESULT_FROM_SETUPAPI"
          Data "IS_ERROR"
          Data "MAKE_SCODE"
          Data "MAKE_HRESULT"
          Data "MOVETO"
          Data "MAKELANGID"
          Data "MAKEROP4"
          Data "PALETTERGB"
          Data "PALETTEINDEX"
          Data "SCODE_CODE"
          Data "SCODE_SEVERITY"
          Data "SUCCEEDED"
          Data "SCODE_FACILITY"
          Data "ZEROMEMORY"
          Data "PBMAIN"
          Data "UPDATEEXPROFILE"
          Data "FILLARRAY"
          Data "PROFILE_ORDERED"
          Data "CALLSSORT"
          Data "TIMESORT"
        	
        End Function
        
        Function CallsSort(Param1 As ProfileMetrics, Param2 As ProfileMetrics) As Long
          If Param1.Calls < Param2.Calls Then
            Function = +1 : Exit Function
          End If
          If Param1.Calls > Param2.Calls Then
            Function = -1 : Exit Function
          End If
          If Param1.Procedure < Param2.Procedure Then
            Function = -1 : Exit Function
          End If
          If Param1.Procedure > Param2.Procedure Then
            Function = +1 : Exit Function
          End If
        End Function
        
        Function TimeSort(Param1 As ProfileMetrics, Param2 As ProfileMetrics) As Long
          If Param1.Time < Param2.Time Then
            Function = +1 : Exit Function
          End If
          If Param1.Time > Param2.Time Then
            Function = -1 : Exit Function
          End If
          If Param1.Procedure < Param2.Procedure Then
            Function = -1 : Exit Function
          End If
          If Param1.Procedure > Param2.Procedure Then
            Function = +1 : Exit Function
          End If
        End Function
        
        Function Profile_Ordered(Profile_Start_Time As Long) As Long
        
          Local sInput, sTemp0, sTemp1, Uncalled As String
          Local fnum, lLineCtr, lUncalledCtr, accepted, i, j, found, lhrs, lmins, lsecs, longest, lTemp0, lTemp1 As Long, tot As Double
          Local ApplicationTime As Single
          Dim Transfer( 1 To 3 ) As String
          Dim UnusedProc() As String
          Local Profile_FileName As String
          
          Local NoOfExclusions As Long
          ReDim Exclusions( 0 ) As String
          NoOfExclusions = FillArray( Exclusions() )
           
          Profile_FileName = CurDir$ & "\" & _ 'Exe.Path$ only returns 8 char Dos names so use CurDir$
                               Exe.Name$ & _ 'Progran running name
                               "_ProfileEx.txt" 'Add a unique identifier to it
          
          Profile Profile_FileName 'create the file
          fnum = FreeFile
        
        retry:
          Try
            Open Profile_FileName For Input As #fnum
          Catch 
            Sleep 100
            GoTo retry
          End Try
          
          FileScan #fnum, Records To lLineCtr ' Get the number of lines
          Dim ProfileData( 1 To lLineCtr ) As ProfileMetrics  ' Create max array of UDTs
          
          For i = 1 To lLineCtr
            Line Input #fnum, sInput
            Parse sInput, Transfer() ' Put line into a holding array
            j = Val(Transfer(2))     ' ie Number of calls
            sTemp0 = UCase$(Transfer(1)) ' ie Procedure name
            Array Scan Exclusions(), = sTemp0, To found
            If IsFalse(found) Then
              sTemp0 = MCase$(Transfer(1)) ' I hate all CAPS as well <smile>
              If j <> 0 Then ' accept for analysis
                Incr accepted
                ProfileData(accepted).Procedure = sTemp0 ' and now transfer data to UDTs
                ProfileData(accepted).Calls = j
                ProfileData(accepted).Time = Val(Transfer(3)) ' ie Time spent
                ProfileData(accepted).TimePerCall = Val(Transfer(3))/j
              Else
                ' Put uncalled procedures into a string - we'll separate them later
                Uncalled = Build$(Uncalled, sTemp0, $CrLf)
              End If
            End If
          Next
          Close #fnum
          
          ReDim Preserve ProfileData( 1 To accepted ) ' Trim the array of UDTs to the lines we accepted
          
          ' Uncalled has a terminating $CrLF which will give an excessive procedure count when parsing later
          Uncalled = RTrim$(Uncalled, $CrLf)
          
          ' Calculate percentage times
          For i = 1 To accepted
            tot = tot + ProfileData(i).Time
          Next
          For i = 1 To accepted
            ProfileData(i).Percentage = Round(ProfileData(i).Time/tot, 3)*100
          Next
          
          ' Find the longest procedure name
          For i = 1 To accepted
            j = Len( Trim$(ProfileData(i).Procedure) )
            If j > longest Then longest = j
          Next
          Let longest = longest + 6 ' bit of elbow room
        
          If IsFile(Profile_FileName) Then Kill Profile_FileName
            
          Open Profile_FileName For Output As #fnum
               
            lhrs = Profile_Start_Time \ 3600
            lmins = (Profile_Start_Time  - (lhrs * 3600)) \ 60
            lsecs = (Profile_Start_Time -  (lhrs * 3600)) - (lmins * 60)
         
            Print #fnum, " Profile for " &  Profile_FileName 
            Print #fnum, " " + Date$ & "    Ran from " & _
                       Using$("##:##:## to ", lhrs, lmins, lsecs) & _
                       Time$ & _
                       Using$(" for #, seconds", (GetTickCount - Profile_Start_Time)/1000)
            
            ' How much of ThisProfile() did we use?
            lProcCtr = 0
            Do While ThisProfile(lProcCtr).NumCalled <> 0
              Incr lProcCtr
            Loop
            If lProcCtr > 0 Then
              ReDim Preserve Thisprofile( 0 To lProcCtr - 1 )
              ' We are going to try and use the intended case for the procedure names
              ' ThisProfile() has the intended case - ProfileData() has mixed case
              ' - originally upper case from FuncName$
              Dim TempProcedures( 1 To lProcCtr ) As String
              For i = 0 To lProcCtr - 1
                TempProcedures(i+1)= ThisProfile(i).Called
              Next
              For i = 1 To accepted
                Array Scan TempProcedures(), Collate UCase, = ProfileData(i).Procedure, To found
                ' Overwrite  ProfileData() with properly cased names, if possible
                If found Then ProfileData(i).Procedure = TempProcedures(found)
              Next
            End If
            
            Print #fnum: Print #fnum, " Alphabetical by Procedure Name:": Print #fnum
            Array Sort ProfileData() ' ie procedures
            GoSub PrintSort
            
            Print #fnum: Print #fnum, " In call frequency order:": Print #fnum
            Array Sort ProfileData(), Using CallsSort
            GoSub PrintSort
                      
            Print #fnum: Print #fnum, " In time used order:": Print #fnum
            Array Sort ProfileData(), Using TimeSort
            GoSub PrintSort
               
            ' Now list the uncalled procedures, if any
            If Uncalled <> "" Then
              Print #fnum
              Print #fnum, " Uncalled procedures:": Print #fnum
              ' How many are there?
              lUncalledCtr = ParseCount(Uncalled, $CrLf)
              ReDim UnusedProc( 1 To lUncalledCtr )
              ' Break string built early and fill array
              Parse Uncalled, UnusedProc(), $CrLf
              Array Sort UnusedProc()
              ' and now print them, spread over the page
              lTemp0 = Len( UnusedProc(1) ) + 2 ' for comma & space
              Print #fnum, UnusedProc(1);
              For i = 2 To lUncalledCtr
                Print #fnum, ", ";
                lTemp0 = lTemp0 + Len( UnusedProc(i) ) + 2
                If lTemp0 > 72 Then
                  Print #1
                  lTemp0 = Len( UnusedProc(i) ) + 2
                End If
                Print #fnum, UnusedProc(i);
              Next
            End If
        
            ' Extended profiling
            If lProcCtr > 0 Then
              Array Sort ThisProfile()
              Print #fnum: Print #fnum
              Print #fnum, " *** Extended profile ***": Print #fnum
              
              ' Build an uppercase version of ProfileData().Procedure
              ReDim ProcUName( 1 To accepted ) As String
              For i = 1 To accepted
                ProcUName(i) = UCase$( ProfileData(i).Procedure )
              Next
              
              ' PBMain is not profiled so use the following - not perfect, but not bad
              ApplicationTime = (GetTickCount + 5 - Profile_Start_Time) ' Added 5ms as we are geting the time early
              
              Local keep, DelayPrint As String, sTotPercent, sThisPercent, ThisPercent As Single, FirstPass As Long
              
              i = 0
              sTemp1 = ""
              FirstPass = -1
              Do
                ' ThisProfile().Caller is uppercase by virtue of FuncName$, therefore sTemp0 is also
                sTemp0 = ThisProfile(i).Caller ' get calling procdure
                If sTemp0 <> sTemp1 Then ' is this different to the last calling procedure
                  If IsFalse(FirstPass) Then
                    Print #fnum, keep + Str$(Round( (100 - sTotPerCent)*lTemp0/ApplicationTime  ,1) ) + "% Influence"
                    Print #fnum, $CrLf + DelayPrint
                    Reset keep: Reset DelayPrint: Reset sTotPercent
                    Print #fnum
                  End If
                  FirstPass = 0
                  ' Get total time spent by calling procedure
                  If Trim$(sTemp0) = "PBMAIN" Then 
                    lTemp0 = ApplicationTime
                    keep = " PBMAIN" + Str$(ApplicationTime)
                  Else
                    ' ProcUName() is uppercase as defined above
                    ' Scanning ProcUName avoids using 'Collate Ucase'
                    Array Scan ProcUName(), = sTemp0, To found
                    lTemp0 = ProfileData(found).Time
                    keep = " " + Trim$(sTemp0) + Str$(lTemp0)
                  End If
                End If
                ' ThisProfile().UCalled is uppercase as written, required in the
                ' building of ThisProfile(), therefore sTemp1 is also
                sTemp1 = ThisProfile(i).UCalled ' get called procedure
                ' ProcUName() is uppercase as defined above
                ' Scanning ProcUName avoids using 'Collate Ucase'
                Array Scan ProcUName(), = sTemp1, To found ' find it in our accepted list
                ' Calculate total time spent by called procedure in calling procedure
                lTemp1 = Int( ThisProfile(i).NumCalled*ProfileData(found).TimePerCall ) 
                ' Build output
                sTemp1 = Trim$(ThisProfile(i).Called) ' get rid of those chr$(0)
                sTemp1 = sTemp1 + Space$(longest - Len(sTemp1)) + Str$(ThisProfile(i).NumCalled) + " x" + _
                  Str$( Int( ProfileData(found).TimePerCall ) ) + " =" + Str$(lTemp1) + " ["
                If Trim$(sTemp0) = "PBMAIN" Then
                  sThisPercent = lTemp1*100/ApplicationTime
                  ThisPercent = Round( sThisPercent, 1 )
                  sTotPercent = sTotPercent + sThisPercent 
                  DelayPrint =  DelayPrint + "   " + sTemp1 + Trim$(Str$( ThisPercent )) + "%" +"]" + $CrLf
                Else
                  sThisPercent =  lTemp1*100/lTemp0
                  ThisPercent =  Round( sThispercent,1 )
                  sTotPercent = sTotPercent + sThisPercent
                  DelayPrint =  DelayPrint + "   " + sTemp1 + Trim$(Str$( ThisPercent )) + "%" + "]" + $CrLf
                End If
                sTemp1 = Stemp0 ' Copy last calling procedure
                Incr i                                                                                            
              Loop Until i = lProcCtr
              
              Print #fnum, keep + Str$(Round( (100 - sTotPerCent)*lTemp0/ApplicationTime  ,1) ) + "% Influence"
              Print #fnum, $CrLf + DelayPrint
              
              For i = 0 To lProcCtr - 1
                TempProcedures(i+1)= ThisProfile(i).Caller
              Next
              ' Find standalone procedures
              For i = 1 To accepted
                Array Scan TempProcedures(), Collate UCase, = ProfileData(i).Procedure, To found
                If IsFalse(found) Then
                  Print #fnum, " ";Trim$(ProcUname(i)); Str$(ProfileData(i).Time); Str$(Round(100*ProfileData(i).Time/ApplicationTime, 1)) + "% Influence"
                End If     
              Next
            End If
            ' End of Extended profiling
                          
          Close #fnum
          
          j = Shell("NotePad.exe " + Profile_FileName)
          
          Exit Function
          
        PrintSort:
          Print #fnum, Space$(8 + longest);"Calls      Tot ms     ms/call     %": Print #fnum  
          For i = 1 To accepted
            sTemp0 = Trim$(ProfileData(i).Procedure)
            Print #fnum, Using$("###",i);") ";sTemp0;Space$(longest - Len(sTemp0));Using$("########", ProfileData(i).Calls); _
            Using$("############", ProfileData(i).Time);Using$("############", Int( ProfileData(i).TimePerCall) );Using$("   ##.#", ProfileData(i).Percentage);"%"
          Next
          Return
        
        End Function
        Last edited by David Roberts; 24 Nov 2008, 01:09 PM. Reason: 'End Function' missing at end of code

        Comment


        • #5
          In particular, I want to rank in order of % influence.
          Now done.

          I got the feeling the other day that we may have information overkill so I've changed the way NotePad is used.

          Profile_Ordered has had a name change to ProfileEx and an optional parameter has been added giving 'Function ProfileEx(Profile_Start_Time As Long, Opt x As Long) As Long'.

          If the optional parameter exists then a full report is dumped to file but not NotePad. The file name has a tail of '_ProfileExFull.txt'.

          If the optional parameter does not exist then a short report is both dumped to file and NotePad. The file name in this case has a tail, not surprisingly, of '_ProfileExShort.txt'.

          A short report is the full report without the alphabetical, call frequency and time used tables.

          The second example above, with an unused ProcFour added, in short report now looks like this:

          Code:
           Profile for C:\PBWin\Profiling\test_ProfileExShort.txt
           11-27-2008 09:03:55 running for 17 seconds
          
           Uncalled procedures:
          
           Procfour
          
           *** Extended profile ***
          
           Parent procedures:
          
           PBMAIN 17172 5.8% Influence
          
             ProcOne         2 x 6531 = 13063 [76.1%]
             ProcThree       6 x 301 = 1807 [10.5%]
             ProcTwo         1 x 1300 = 1300 [7.6%]
          
           PROCONE 13063 5% Influence
          
             ProcThree       6 x 301 = 1807 [13.8%]
             ProcTwo         8 x 1300 = 10402 [79.6%]
          
           PROCTWO 11703 20.8% Influence
          
             ProcThree       27 x 301 = 8134 [69.5%]
          
           Standalone procedures:
          
           PROCTHREE 11750 68.4% Influence
          
           Sorted influences (Omitting < 5%):
          
           PROCTHREE     68.4%
           PROCTWO       20.8%
           PBMAIN         5.8%
           PROCONE        5.0%
          It could be argued that the full report is surplus to requirements since its examination is done in ProfileEx's extended profiling.

          One other change made is the head of the report. Timer wraps every 24 hours, GetTickCount wraps every 49.7 days and has a millisecond resolution so Timer has been dropped.

          With regard the sorted influences, values less than 5% are omitted. For any influence to be fully represented in the application session time the associated procedure's focus code would have to run at the speed of light. The % influence then is a target to aim for and can never be achieved, says Einstein - not me.

          I mentioned that Egress has to be inserted before each and every procedure call. This is best practice but if a particular procedure's use was bypassed on all occasions then it would not appear in the extended profile. It would have no bearing on the remaining figures. If a procedure call took 10% of the time of it's 'parent' procedure then it would, obviously, still be 10% whether a 'sibling' procedure is profiled or not.
          This is still true but the influence figures would get distorted. So, use Egress before each and every procedure call.

          This should be the final version:
          Code:
          '-------------------------------------------------------
          '  ProfileEx.inc for PB9 or CC5
          '
          '  At the top of PBMain put the following lines:
          '
          '  Local Profile_Start_Time As Long
          '  Profile_Start_Time = GetTickCount
          '  lMaxSize = 999
          '  ReDim ThisProfile( 0 To lMaxSize ) As ExtendedProfile
          '  Local i As Long
          '  For i = 0 To lMaxSize
          '    ThisProfile(i).Caller = "~"
          '    Thisprofile(i).Called = "~"
          '  Next
          '
          ' At the bottom of PBMain put this line:
          '
          ' Either
          '   ProfileEx(Profile_Start_Time, 1) ' for full report
          ' Or
          '   ProfileEx(Profile_Start_Time)    ' for short report
          '-------------------------------------------------------
          
          ' For extended profiing ---------------
          Type ExtendedProfile
            Caller As String * 50
            Called As String * 50
            Ucalled As String * 50
            NumCalled As Long
          End Type
          Global ThisProfile() As ExtendedProfile
          Global lMaxSize, lProcCtr As Long
          '--------------------------------------
          
          Type ProfileMetrics
            Procedure As String * 50
            Calls As Long
            Time As Long
            TimePerCall As Single
            Percentage As Single
          End Type
          
          Macro Egress(prm)
            UpDateExProfile( FuncName$, prm )
          End Macro
          
          Function UpdateExProfile(FromProc As String, ToProc As String ) As Long
          Local i As Long, sTemp0, sTemp1 As String
          
          i = 0
            Do
              stemp0 = Trim$( ThisProfile(i).Caller )
              If sTemp0 = "~" Then
                ThisProfile(i).Caller = FromProc
                ThisProfile(i).UCalled = UCase$(ToProc)
                ThisProfile(i).Called = ToProc
                ThisProfile(i).NumCalled = 1
                Exit Loop
              Else
                If sTemp0 = FromProc Then
                  sTemp1 = Trim$(ThisProfile(i).UCalled)
                  If sTemp1 = "~" Then
                    ThisProfile(i).UCalled = UCase$(ToProc)
                    ThisProfile(i).Called = ToProc
                    ThisProfile(i).NumCalled = 1
                    Exit Loop
                  Else
                    If sTemp1 = UCase$(ToProc) Then
                      Incr ThisProfile(i).NumCalled
                      Exit Loop
                    End If
                  End If
                End If
              End If
              Incr i
              If i > lMaxSize Then
                lMaxSize = lMaxSize + 500
                ReDim Preserve ThisProfile( 0 To lMaxSize )
              End If
            Loop
            
          End Function 
          
          Function FillArray( ArrayEx() As String ) As Long
          Local x  As Long
          
          	ReDim ArrayEx( 1 To DataCount ) As String
          	
          	For x = 1 To DataCount
          		ArrayEx( x ) = Read$( x )
            Next
          
          	Function = DataCount
          	
          	' Exclusion list
          	Data "CREATEDIALOG"
            Data "CREATEDIALOGINDIRECT"
            Data "CMYK"
            Data "COPYMEMORY"
            Data "CREATEWINDOW"
            Data "DIALOGBOX"
            Data "DIALOGBOXINDIRECT"
            Data "FILLMEMORY"
            Data "FAILED"
            Data "GETNEXTWINDOW"
            Data "GETYVALUE"
            Data "GETHINST"
            Data "GETBVALUE"
            Data "GETGVALUE"
            Data "GETRVALUE"
            Data "GETMVALUE"
            Data "GETCVALUE"
            Data "GETKVALUE"
            Data "HRESULT_SEVERITY"
            Data "HRESULT_FACILITY"
            Data "HRESULT_FROM_WIN32"
            Data "HRESULT_CODE"
            Data "HRESULT_FROM_NT"
            Data "HRESULT_FROM_SETUPAPI"
            Data "IS_ERROR"
            Data "MAKE_SCODE"
            Data "MAKE_HRESULT"
            Data "MOVETO"
            Data "MAKELANGID"
            Data "MAKEROP4"
            Data "PALETTERGB"
            Data "PALETTEINDEX"
            Data "SCODE_CODE"
            Data "SCODE_SEVERITY"
            Data "SUCCEEDED"
            Data "SCODE_FACILITY"
            Data "ZEROMEMORY"
            Data "PBMAIN"
            Data "UPDATEEXPROFILE"
            Data "FILLARRAY"
            Data "PROFILEEX"
            Data "CALLSSORT"
            Data "TIMESORT"
          	
          End Function
          
          Function CallsSort(Param1 As ProfileMetrics, Param2 As ProfileMetrics) As Long
            If Param1.Calls < Param2.Calls Then
              Function = +1 : Exit Function
            End If
            If Param1.Calls > Param2.Calls Then
              Function = -1 : Exit Function
            End If
            If Param1.Procedure < Param2.Procedure Then
              Function = -1 : Exit Function
            End If
            If Param1.Procedure > Param2.Procedure Then
              Function = +1 : Exit Function
            End If
          End Function
          
          Function TimeSort(Param1 As ProfileMetrics, Param2 As ProfileMetrics) As Long
            If Param1.Time < Param2.Time Then
              Function = +1 : Exit Function
            End If
            If Param1.Time > Param2.Time Then
              Function = -1 : Exit Function
            End If
            If Param1.Procedure < Param2.Procedure Then
              Function = -1 : Exit Function
            End If
            If Param1.Procedure > Param2.Procedure Then
              Function = +1 : Exit Function
            End If
          End Function
          
          Function ProfileEx(Profile_Start_Time As Long, Opt x As Long) As Long
          
            Local sInput, sTemp0, sTemp1, Uncalled As String
            Local fnum, lLineCtr, lUncalledCtr, accepted, i, j, found, lhrs, lmins, lsecs, longest, lTemp0, lTemp1, DisplayShort As Long, tot As Double
            Local ApplicationTime As Single
            Dim Transfer( 1 To 3 ) As String
            Dim UnusedProc() As String
            Local Profile_FileName As String
            
            Local NoOfExclusions As Long
            ReDim Exclusions( 0 ) As String
            NoOfExclusions = FillArray( Exclusions() )
             
            Profile_FileName = CurDir$ & "\" & _ 'Exe.Path$ only returns 8 char Dos names so use CurDir$
                                 Exe.Name$ + "_ProfileEx"
            If IsMissing(x) Then
              DisplayShort = %True
              Profile_Filename = Profile_FileName + "Short.txt"
            Else
              DisplayShort = %False
              Profile_Filename = Profile_FileName + "Full.txt"
            End If
            
            Profile Profile_FileName 'create the file
            fnum = FreeFile
          
          retry:
            Try
              Open Profile_FileName For Input As #fnum
            Catch 
              Sleep 100
              GoTo retry
            End Try
            
            FileScan #fnum, Records To lLineCtr ' Get the number of lines
            Dim ProfileData( 1 To lLineCtr ) As ProfileMetrics  ' Create max array of UDTs
            
            For i = 1 To lLineCtr
              Line Input #fnum, sInput
              Parse sInput, Transfer() ' Put line into a holding array
              j = Val(Transfer(2))     ' ie Number of calls
              sTemp0 = UCase$(Transfer(1)) ' ie Procedure name
              Array Scan Exclusions(), = sTemp0, To found
              If IsFalse(found) Then
                sTemp0 = MCase$(Transfer(1)) ' I hate all CAPS as well <smile>
                If j <> 0 Then ' accept for analysis
                  Incr accepted
                  ProfileData(accepted).Procedure = sTemp0 ' and now transfer data to UDTs
                  ProfileData(accepted).Calls = j
                  ProfileData(accepted).Time = Val(Transfer(3)) ' ie Time spent
                  ProfileData(accepted).TimePerCall = Val(Transfer(3))/j
                Else
                  ' Put uncalled procedures into a string - we'll separate them later
                  Uncalled = Build$(Uncalled, sTemp0, $CrLf)
                End If
              End If
            Next
            Close #fnum
            
            ReDim Preserve ProfileData( 1 To accepted ) ' Trim the array of UDTs to the lines we accepted
            
            ' Uncalled has a terminating $CrLF which will give an excessive procedure count when parsing later
            Uncalled = RTrim$(Uncalled, $CrLf)
            
            ' Calculate percentage times
            For i = 1 To accepted
              tot = tot + ProfileData(i).Time
            Next
            For i = 1 To accepted
              ProfileData(i).Percentage = Round(ProfileData(i).Time/tot, 3)*100
            Next
            
            ' Find the longest procedure name
            For i = 1 To accepted
              j = Len( Trim$(ProfileData(i).Procedure) )
              If j > longest Then longest = j
            Next
            Let longest = longest + 6 ' bit of elbow room
          
            Open Profile_FileName For Output As #fnum
                 
              Print #fnum, " Profile for " +  Profile_FileName 
              Print #fnum, " " + Date$ + " " + Time$ & " running" + Using$(" for # seconds", (GetTickCount - Profile_Start_Time)/1000)
              
              ' How much of ThisProfile() did we use?
              lProcCtr = 0
              Do While ThisProfile(lProcCtr).NumCalled <> 0
                Incr lProcCtr
              Loop
              If lProcCtr > 0 Then
                ReDim Preserve Thisprofile( 0 To lProcCtr - 1 )
                ' We are going to try and use the intended case for the procedure names
                ' ThisProfile() has the intended case - ProfileData() has mixed case
                ' - originally upper case from FuncName$
                Dim TempProcedures( 1 To lProcCtr ) As String
                For i = 0 To lProcCtr - 1
                  TempProcedures(i+1)= ThisProfile(i).Called
                Next
                For i = 1 To accepted
                  Array Scan TempProcedures(), Collate UCase, = ProfileData(i).Procedure, To found
                  ' Overwrite  ProfileData() with properly cased names, if possible
                  If found Then ProfileData(i).Procedure = TempProcedures(found)
                Next
              End If
              
              If IsFalse(DisplayShort) Then
                Print #fnum: Print #fnum, " Alphabetical by Procedure Name:": Print #fnum
                Array Sort ProfileData() ' ie procedures
                GoSub PrintSort
                
                Print #fnum: Print #fnum, " In call frequency order:": Print #fnum
                Array Sort ProfileData(), Using CallsSort
                GoSub PrintSort
                          
                Print #fnum: Print #fnum, " In time used order:": Print #fnum
                Array Sort ProfileData(), Using TimeSort
                GoSub PrintSort
              End If
                 
              ' Now list the uncalled procedures, if any
              If Uncalled <> "" Then
                Print #fnum
                Print #fnum, " Uncalled procedures:": Print #fnum
                ' How many are there?
                lUncalledCtr = ParseCount(Uncalled, $CrLf)
                ReDim UnusedProc( 1 To lUncalledCtr )
                ' Break string built early and fill array
                Parse Uncalled, UnusedProc(), $CrLf
                Array Sort UnusedProc()
                ' and now print them, spread over the page
                lTemp0 = Len( UnusedProc(1) ) + 2 ' for comma & space
                Print #fnum, " ";UnusedProc(1);
                For i = 2 To lUncalledCtr
                  Print #fnum, ", ";
                  lTemp0 = lTemp0 + Len( UnusedProc(i) ) + 2
                  If lTemp0 > 72 Then
                    Print #fnum: Print #fnum," "; 
                    lTemp0 = Len( UnusedProc(i) ) + 2
                  End If
                  Print #fnum, UnusedProc(i);
                Next
              End If
              
              ' Extended profiling
              If lProcCtr > 0 Then
                Array Sort ThisProfile()
                Print #fnum: Print #fnum
                Print #fnum, " *** Extended profile ***"
                Print #fnum: Print #fnum, " Parent procedures:": Print #fnum
                
                ' Build an uppercase version of ProfileData().Procedure
                ReDim ProcUName( 1 To accepted ) As String
                For i = 1 To accepted
                  ProcUName(i) = UCase$( ProfileData(i).Procedure )
                Next
                
                Local keep, DelayPrint As String, sTotPercent, sThisPercent As Single, FirstPass, InfluenceCtr As Long
                Dim InfluenceName( 0 To Accepted ) As String
                Dim Influence( 0 To accepted ) As Single
                      
                InfluenceCtr = -1
                i = 0
                sTemp1 = ""
                FirstPass = -1
                
                ' PBMain is not profiled so use the following - not perfect, but not bad
                ApplicationTime = (GetTickCount - Profile_Start_Time)
                
                ' Find parent procedures, if any
                Do
                  ' ThisProfile().Caller is uppercase by virtue of FuncName$, therefore sTemp0 is also
                  sTemp0 = ThisProfile(i).Caller ' get calling procdure
                  
                  If sTemp0 <> sTemp1 Then ' is this different to the last calling procedure
                    If IsFalse(FirstPass) Then
                      Influence(InfluenceCtr) = Round( (100 - sTotPerCent)*lTemp0/ApplicationTime, 1)
                      Print #fnum, keep + Str$( Influence(InfluenceCtr) ) + "% Influence"
                      Print #fnum, $CrLf + DelayPrint
                      Reset keep: Reset DelayPrint: Reset sTotPercent
                    End If
                    FirstPass = 0
                    
                    ' Get total time spent by calling procedure
                    If Trim$(sTemp0) = "PBMAIN" Then 
                      lTemp0 = ApplicationTime
                      keep = " PBMAIN" + Str$(ApplicationTime)
                      Incr InfluenceCtr
                      InfluenceName(InfluenceCtr) = " PBMAIN"
                    Else
                      ' ProcUName() is uppercase as defined above
                      ' Scanning ProcUName avoids using 'Collate Ucase'
                      Array Scan ProcUName(), = sTemp0, To found
                      lTemp0 = ProfileData(found).Time
                      keep = " " + Trim$(sTemp0) + Str$(lTemp0)
                      Incr InfluenceCtr
                      InfluenceName(InfluenceCtr) = " " + Trim$(sTemp0)
                    End If
                  End If ' sTemp0 <> sTemp1
                  
                  ' ThisProfile().UCalled is uppercase as written, required in the
                  ' building of ThisProfile(), therefore sTemp1 is also
                  sTemp1 = ThisProfile(i).UCalled ' get called procedure
                  
                  ' ProcUName() is uppercase as defined above
                  ' Scanning ProcUName avoids using 'Collate Ucase'
                  Array Scan ProcUName(), = sTemp1, To found ' find it in our accepted list
                  
                  ' Calculate total time spent by called procedure in calling procedure
                  lTemp1 = Int( ThisProfile(i).NumCalled*ProfileData(found).TimePerCall )
                   
                  ' Build output
                  sTemp1 = Trim$(ThisProfile(i).Called) ' get rid of those chr$(0)
                  sTemp1 = sTemp1 + Space$(longest - Len(sTemp1)) + Str$(ThisProfile(i).NumCalled) + " x" + _
                    Str$( Int( ProfileData(found).TimePerCall ) ) + " =" + Str$(lTemp1) + " ["
                  If Trim$(sTemp0) = "PBMAIN" Then
                    sThisPercent = lTemp1*100/ApplicationTime
                    sTotPercent = sTotPercent + sThisPercent 
                    DelayPrint =  DelayPrint + "   " + sTemp1 + Trim$(Str$( Round( sThisPercent, 1 ) )) + "%" +"]" + $CrLf
                  Else
                    sThisPercent =  lTemp1*100/lTemp0
                    sTotPercent = sTotPercent + sThisPercent
                    DelayPrint =  DelayPrint + "   " + sTemp1 + Trim$(Str$( Round( sThispercent, 1 ) )) + "%" + "]" + $CrLf
                  End If
                  sTemp1 = Stemp0 ' Copy last calling procedure
                  Incr i                                                                                            
                Loop Until i = lProcCtr
                
                Influence(InfluenceCtr) =  Round( (100 - sTotPerCent)*lTemp0/ApplicationTime, 1)
                Print #fnum, keep + Str$( Influence(InfluenceCtr) ) + "% Influence"
                Print #fnum, $CrLf + DelayPrint
                
                ' Find standalone procedures, if any
                For i = 0 To lProcCtr - 1
                  TempProcedures(i+1)= ThisProfile(i).Caller
                Next
                [COLOR="Red"]Array Sort ProcUname(), TagArray ProfileData()[/COLOR]
                j = 0
                For i = 1 To accepted
                  Array Scan TempProcedures(), Collate UCase, = [COLOR="Red"]ProcUname(i)[/COLOR], To found
                  If IsFalse(found) Then
                    If j = 0 Then
                      Print #fnum, " Standalone procedures:": Print #fnum
                      j = 1
                    End If
                    Incr InfluenceCtr
                    InfluenceName(InfluenceCtr) = " " + Trim$(ProcUname(i))
                    Influence(InfluenceCtr) = Round(100*ProfileData(i).Time/ApplicationTime, 1)
                    Print #fnum, " ";Trim$(ProcUname(i)); Str$(ProfileData(i).Time); Str$( Influence(InfluenceCtr) ) + "% Influence"
                  End If     
                Next
                
                ' Sort influences
                ReDim Preserve InfluenceName( 0 To InfluenceCtr )
                ReDim Preserve Influence( 0 To InfluenceCtr )
                Array Sort Influence(), TagArray InfluenceName(), Descend
                
                Print #fnum: Print #fnum, " Sorted influences (Omitting < 5%):": Print #fnum
                For i = 0 To InfluenceCtr
                  If Influence(i) < 5 Then Exit For
                  Print#fnum, InfluenceName(i);Space$(longest - Len(InfluenceName(i)));Using$("##.#", Influence(i));"%"
                Next
                
              End If ' lProcCtr > 0
              ' End of Extended profiling
                            
            Close #fnum
            
            If DisplayShort Then Shell("NotePad.exe " + Profile_FileName)
              
            Exit Function
            
          PrintSort:
            Print #fnum, Space$(8 + longest);"Calls      Tot ms     ms/call     %": Print #fnum  
            For i = 1 To accepted
              sTemp0 = Trim$(ProfileData(i).Procedure)
              Print #fnum, Using$("###",i);") ";sTemp0;Space$(longest - Len(sTemp0));Using$("########", ProfileData(i).Calls); _
              Using$("############", ProfileData(i).Time);Using$("############", Int( ProfileData(i).TimePerCall) );Using$("   ##.#", ProfileData(i).Percentage);"%"
            Next
            Return
          
          End Function
          Last edited by David Roberts; 29 Nov 2008, 07:06 PM. Reason: Removed a comment - no longer true

          Comment


          • #6
            Deleted
            Last edited by Gösta H. Lovgren-2; 27 Nov 2008, 01:39 PM.
            It's a pretty day. I hope you enjoy it.

            Gösta

            JWAM: (Quit Smoking): http://www.SwedesDock.com/smoking
            LDN - A Miracle Drug: http://www.SwedesDock.com/LDN/

            Comment


            • #7
              Comments here.

              Comment


              • #8
                The standalone procedures were found to be unsorted.

                In the above toward the bottom there are two pieces of red text. The first is an insertion and the second is a replacement.

                Sorted.

                Comment


                • #9
                  Oops, that introduced a bug. The influences no longer added to 100%.

                  I forgot to tag ProfileData() with ProcUname() in the inserted line.

                  Ship shape again.

                  Comment

                  Working...
                  X