Ability to sort and/or suppress small entries

ftimings/ftimings.f90

@@ -20,22 +20,26 @@ module ftimings
     character(len=name_length) :: name
     integer(kind=C_INT64_T) :: micros
     integer :: count
-    type(node_t), pointer :: firstChild
-    type(node_t), pointer :: lastChild
-    type(node_t), pointer :: parent
-    type(node_t), pointer :: nextSibling
+    type(node_t), pointer :: firstChild => NULL()
+    type(node_t), pointer :: lastChild => NULL()
+    type(node_t), pointer :: parent => NULL()
+    type(node_t), pointer :: nextSibling => NULL()
     contains
       procedure, pass :: new_child => node_new_child
       procedure, pass :: get_child => node_get_child
-      procedure, pass :: print_graph => node_print_graph
+      procedure, pass :: get_micros => node_get_micros
+      procedure, pass :: is_running => node_is_running
       procedure, pass :: sum_of_children => node_sum_of_children
       procedure, pass :: sum_of_children_with_name => node_sum_of_children_with_name
+      procedure, pass :: sum_of_children_below => node_sum_of_children_below
+      procedure, pass :: print_graph => node_print_graph
+      procedure, pass :: sort_children => node_sort_children
   end type
 
   type timer_t
     logical :: active = .false.
-    type(node_t), pointer :: root
-    type(node_t), pointer :: current_node
+    type(node_t), pointer :: root => NULL()
+    type(node_t), pointer :: current_node => NULL()
     contains
       procedure, pass :: start => timer_start
       procedure, pass :: stop => timer_stop
@@ -47,9 +51,11 @@ module ftimings
       procedure, pass :: in_entries => timer_in_entries
       procedure, pass :: get => timer_get
       procedure, pass :: since => timer_since
+      procedure, pass :: sort => timer_sort
   end type
 
   character(len=name_length), parameter :: own = "(own)"
+  character(len=name_length), parameter :: below = "(below threshold)"
 
   contains
 
@@ -107,6 +113,22 @@ module ftimings
     nullify(child)
   end function
 
+  function node_get_micros(self) result(micros)
+    class(node_t), intent(in) :: self
+    integer(kind=C_INT64_T) :: micros
+    micros = self%micros
+    if (micros < 0) then
+      ! we have not finished, give time up to NOW
+      micros = micros + microseconds_since_epoch()
+    endif
+  end function
+
+  function node_is_running(self) result(is_running)
+    class(node_t), intent(in) :: self
+    logical :: is_running
+    is_running = self%micros < 0
+  end function
+
   recursive subroutine deallocate_node(entry)
     type(node_t), intent(inout), pointer :: entry
     type(node_t), pointer :: nextSibling
@@ -130,11 +152,7 @@ module ftimings
     sum_time = 0
     cur_entry => self%firstChild
     do while (associated(cur_entry))
-      sum_time = sum_time + cur_entry%micros
-      if (cur_entry%micros < 0) then
-        ! child has not finished, give time up to NOW
-        sum_time = sum_time + microseconds_since_epoch()
-      endif
+      sum_time = sum_time + cur_entry%get_micros()
       cur_entry => cur_entry%nextSibling
     enddo
   end function
@@ -157,48 +175,142 @@ module ftimings
     enddo
   end function
 
-  recursive subroutine node_print_graph(self, indent_level)
+  function node_sum_of_children_below(self, threshold) result(sum_time)
     class(node_t), intent(in) :: self
+    real(kind=rk), intent(in), optional :: threshold
+    type(node_t), pointer :: cur_entry
+    integer(kind=C_INT64_T) :: sum_time
+
+    sum_time = 0
+
+    if (.not. present(threshold)) then
+      return
+    endif
+
+    cur_entry => self%firstChild
+
+    do while (associated(cur_entry))
+      if (cur_entry%get_micros() * 1e-6_rk < threshold) then
+        sum_time = sum_time + cur_entry%get_micros()
+      endif
+      cur_entry => cur_entry%nextSibling
+    enddo
+  end function
+
+  subroutine node_print_line(indent_level, label, number, total)
     integer, intent(in) :: indent_level
+    character(len=name_length), intent(in) :: label
+    integer(kind=C_INT64_T), intent(in) :: number, total
+    character(len=64) :: format_spec
+
+    write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6,10x,f5.3)")') (indent_level + 1) * 2 + 2, name_length
+    write(*,format_spec) label, real(number, kind=rk) * 1e-6_rk, real(number, kind=rk) / real(total, kind=rk)
+  end subroutine
 
+  recursive subroutine node_print_graph(self, indent_level, threshold, is_sorted, total)
+    class(node_t), intent(in) :: self
+    integer, intent(in) :: indent_level
+    real(kind=rk), intent(in), optional :: threshold
+    logical, intent(in), optional :: is_sorted
+    integer(kind=C_INT64_T), intent(in), optional :: total
+
+    type(node_t), pointer :: node
     character(len=64) :: format_spec
     character(len=name_length) :: name, suffix
     integer :: i
-    integer(kind=C_INT64_T) :: current_ms
+    integer(kind=C_INT64_T) :: current_us, own_us, below_threshold_us, total_act
+    real(kind=rk) :: threshold_act
+    logical :: is_sorted_act, print_own, print_threshold
 
-    if (self%micros < 0) then
-      ! still running, give time up to NOW
-      current_ms = self%micros + microseconds_since_epoch()
-      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6,"" (running)"")")') indent_level * 2 + 2, len(self%name)
+    if (present(threshold)) then
+      threshold_act = threshold
     else
-      current_ms = self%micros
-      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6)")') indent_level * 2 + 2, len(self%name)
+      threshold_act = 0
     endif
 
-    if (self%count > 1) then
-      write(suffix, '(" (",i0,"x)")') self%count
-      write(name, '(a,a)') self%name(1:min(name_length - len(trim(suffix)), len(trim(self%name)))), trim(suffix)
+    if (present(is_sorted)) then
+      is_sorted_act = is_sorted
     else
-      name = self%name
+      is_sorted_act = .false.
+    endif
+
+    current_us = self%get_micros()
+
+    if (present(total)) then
+      total_act = total
+    else
+      total_act = current_us
+    endif
+
+    own_us = current_us - self%sum_of_children()
+    below_threshold_us = self%sum_of_children_below(threshold)
+
+    print_own = associated(self%firstChild)
+    print_threshold = below_threshold_us > 0
+
+    if (self%is_running()) then
+      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6,10x,f5.3,"" (running)"")")') indent_level * 2 + 2, len(self%name)
+    else
+      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6,10x,f5.3)")') indent_level * 2 + 2, len(self%name)
+    endif
+
+    if (current_us * 1e-6_rk > threshold_act) then
+      if (self%count > 1) then
+        write(suffix, '(" (",i0,"x)")') self%count
+        write(name, '(a,a)') self%name(1:min(name_length - len(trim(suffix)), len(trim(self%name)))), trim(suffix)
+      else
+        name = self%name
+      endif
+      do i = len(trim(name)) + 2, name_length
+        name(i:i) = "."
+      end do
+      write(*,format_spec) name, real(current_us, kind=rk) * 1e-6_rk, real(current_us, kind=rk) / real(total_act, kind=rk)
+    else
+      return
     endif
-    do i = len(trim(name)) + 2, name_length
-      name(i:i) = "."
-    end do
-    write(*,format_spec) name, real(current_ms) / 1e6
 
-    if (associated(self%firstChild)) then
-      write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6)")') (indent_level + 1) * 2 + 2, len(self%name)
-      write(*,format_spec) own, real(current_ms - self%sum_of_children()) / 1e6
+    if ((.not. is_sorted_act) .and. print_own) then
+      call node_print_line(indent_level, own, own_us, current_us)
+      print_own = .false.
     endif
 
-    if (associated(self%firstChild)) then
-      call self%firstChild%print_graph(indent_level + 1)
+    if ((.not. is_sorted_act) .and. print_threshold) then
+      call node_print_line(indent_level, below, below_threshold_us, current_us)
+      print_threshold = .false.
     endif
-    if (associated(self%nextSibling)) then
-      call self%nextSibling%print_graph(indent_level)
+
+    node => self%firstChild
+    do while (associated(node))
+
+      if (print_own) then
+        if (node%get_micros() <= own_us) then
+          call node_print_line(indent_level, own, own_us, current_us)
+          print_own = .false.
+        endif
+      endif
+
+      if (print_threshold) then
+        if (node%get_micros() <= below_threshold_us) then
+          call node_print_line(indent_level, below, below_threshold_us, current_us)
+          print_threshold = .false.
+        endif
+      endif
+
+      call node%print_graph(indent_level + 1, threshold, is_sorted, current_us)
+      node => node%nextSibling
+    end do
+
+    if (print_own) then
+      call node_print_line(indent_level, own, own_us, current_us)
     endif
+    if (print_threshold) then
+      call node_print_line(indent_level, below, below_threshold_us, current_us)
+    endif
+
   end subroutine
 
+  ! Public module interface:
+
   subroutine timer_enable(self)
     class(timer_t), intent(inout), target :: self
     self%active = .true.
@@ -215,8 +327,6 @@ module ftimings
     is = self%active
   end function
 
-  ! Public module interface:
-
   subroutine timer_start(self, name, replace)
     class(timer_t), intent(inout), target :: self
     character(len=*), intent(in)  :: name
@@ -240,49 +350,47 @@ module ftimings
 
     if (.not. associated(self%current_node)) then
       ! First call to timer_start()
-      allocate(self%current_node)
-      self%root => self%current_node
-      node => self%current_node
-      nullify(node%parent)
-      nullify(node%firstChild)
-      nullify(node%lastChild)
-      nullify(node%nextSibling)
-      node%name = name
-      node%micros = - microseconds_since_epoch()
-      node%count = 1
-    else
-      ! existing tree
-      if (string_eq(self%current_node%name, name)) then
-        !$omp critical
-        write(0,*) "Recursion error! Printing tree so far.."
-        write(0,*) "Got %start(""" // trim(name) // """), while %start(""" // trim(name) // """) was still active"
-        !$ write(*,*) "omp_get_thread_num() = ", omp_get_thread_num()
-        !$ write(*,*) "omp_get_num_threads() = ", omp_get_num_threads()
-        !$ write(*,*) "omp_get_level() = ", omp_get_level()
-        !$ do i = 0, omp_get_level()
-        !$   write(*,*) "omp_get_ancestor_thread_num(", i, ") = ", omp_get_ancestor_thread_num(i)
-        !$ end do
-        call self%root%print_graph(0)
-        !$omp end critical
-        stop "timer_start() while same timer was active"
-      endif
-      node => self%current_node%get_child(name)
-      if (.not. associated(node)) then
-        node => self%current_node%new_child(name)
-      else if (present(replace)) then
-        if (replace) then
-          node%micros = 0
-          node%count = 0
-          if (associated(node%firstChild)) then
-            call deallocate_node(node%firstChild)
-            nullify(node%firstChild)
-            nullify(node%lastChild)
-          endif
+      allocate(self%root)
+      self%root%name = "[Timings]"
+      self%root%micros = -microseconds_since_epoch()
+      self%root%count = 1
+      nullify(self%root%firstChild)
+      nullify(self%root%lastChild)
+      nullify(self%root%parent)
+      nullify(self%root%nextSibling)
+      self%current_node => self%root
+    endif
+
+    if (string_eq(self%current_node%name, name)) then
+      !$omp critical
+      write(0,*) "Recursion error! Printing tree so far.."
+      write(0,*) "Got %start(""" // trim(name) // """), while %start(""" // trim(name) // """) was still active"
+      !$ write(*,*) "omp_get_thread_num() = ", omp_get_thread_num()
+      !$ write(*,*) "omp_get_num_threads() = ", omp_get_num_threads()
+      !$ write(*,*) "omp_get_level() = ", omp_get_level()
+      !$ do i = 0, omp_get_level()
+      !$   write(*,*) "omp_get_ancestor_thread_num(", i, ") = ", omp_get_ancestor_thread_num(i)
+      !$ end do
+      call self%root%print_graph(0)
+      !$omp end critical
+      stop "timer_start() while same timer was active"
+    endif
+    node => self%current_node%get_child(name)
+    if (.not. associated(node)) then
+      node => self%current_node%new_child(name)
+    else if (present(replace)) then
+      if (replace) then
+        node%micros = 0
+        node%count = 0
+        if (associated(node%firstChild)) then
+          call deallocate_node(node%firstChild)
+          nullify(node%firstChild)
+          nullify(node%lastChild)
         endif
       endif
-      node%micros = node%micros - microseconds_since_epoch()
-      node%count = node%count + 1
     endif
+    node%micros = node%micros - microseconds_since_epoch()
+    node%count = node%count + 1
 
     self%current_node => node
 
@@ -317,9 +425,11 @@ module ftimings
       call self%free()
       self%active = .false.
       error = .true.
+    else if (len(trim(name)) == 0) then
+      write(0,'(a)') "Warning: Expected %stop(""" // trim(self%current_node%name)  // """), but got %stop("""")"
     else if (.not. string_eq(self%current_node%name, name)) then
       write(0,'(a)') "Expected %stop(""" // trim(self%current_node%name)  // """), but got %stop(""" // trim(name) // &
-        & """, disabling timings)"
+        & """), disabling timings"
       call self%free()
       self%active = .false.
       error = .true.
@@ -330,11 +440,12 @@ module ftimings
       self%current_node%micros = self%current_node%micros + microseconds_since_epoch()
 
       ! climb up to parent
-      if (associated(self%current_node%parent)) then
-        self%current_node => self%current_node%parent
-      else
-        nullify(self%current_node)
+      if (.not. associated(self%current_node%parent)) then
+        write(0,'(a)') "Error: No valid parent node found for node '" // trim(name) // "'"
+        call self%free()
+        self%active = .false.
       endif
+      self%current_node => self%current_node%parent
 
     endif
     !$omp end master
@@ -350,9 +461,11 @@ module ftimings
     nullify(self%current_node)
   end subroutine
 
-  subroutine timer_print(self, name1, name2, name3, name4)
+  subroutine timer_print(self, name1, name2, name3, name4, threshold, is_sorted)
     class(timer_t), intent(in), target :: self
     character(len=*), intent(in), optional :: name1, name2, name3, name4
+    real(kind=rk), intent(in), optional :: threshold
+    logical, intent(in), optional :: is_sorted
     type(node_t), pointer :: node
 
     if (.not. self%active) then
@@ -388,7 +501,7 @@ module ftimings
         return
       endif
     end if
-    call node%print_graph(0)
+    call node%print_graph(0, threshold, is_sorted)
   end subroutine
 
   !> Return the sum of all entries with a certain name below
@@ -443,12 +556,13 @@ module ftimings
       name = name4
     end if
 
-    s = real(node%sum_of_children_with_name(name), kind=rk) / 1e6_rk
+    s = real(node%sum_of_children_with_name(name), kind=rk) * 1e-6_rk
   end function
 
-  function timer_get(self, name1, name2, name3, name4) result(s)
+  function timer_get(self, name1, name2, name3, name4, name5) result(s)
     class(timer_t), intent(in), target :: self
-    character(len=*), intent(in), optional :: name1, name2, name3, name4
+    ! this is clunky, but what can you do..
+    character(len=*), intent(in), optional :: name1, name2, name3, name4, name5
     real(kind=rk) :: s
     type(node_t), pointer :: node
 
@@ -487,11 +601,18 @@ module ftimings
         return
       endif
     end if
-    if (node%micros < 0) then
+    if (present(name5)) then
+      node => node%get_child(name5)
+      if (.not. associated(node)) then
+        write(0,'(a)') "Could not descend to """ // trim(name5)  // """"
+        return
+      endif
+    end if
+    if (node%is_running()) then
       write(0,'(a)') "Timer """ // trim(node%name) // """ not yet stopped"
       return
     endif
-    s = real(node%micros, kind=rk) / 1e6_rk
+    s = real(node%micros, kind=rk) * 1e-6_rk
   end function
 
   function timer_since(self, name1, name2, name3, name4) result(s)
@@ -535,7 +656,114 @@ module ftimings
       write(0,'(a)') "Timer """ // trim(node%name) // """ already stopped"
       return
     endif
-    s = real(node%micros + microseconds_since_epoch(), kind=rk) / 1e6_rk
+    s = real(node%micros + microseconds_since_epoch(), kind=rk) * 1e-6_rk
   end function
 
+  ! sort a node_t linked list and return the first and last element
+  subroutine sort_nodes(head, tail)
+    type(node_t), pointer, intent(inout) :: head, tail
+
+    type(node_t), pointer :: p, q, e
+    integer :: insize, nmerges, psize, qsize, i
+
+    if (.not. associated(head)) then
+      nullify(tail)
+      return
+    endif
+
+    insize = 1
+
+    do while (.true.)
+      p => head
+      nullify(head)
+      nullify(tail)
+      nmerges = 0
+
+      do while(associated(p))
+        nmerges = nmerges + 1
+        q => p
+        psize = 0
+        do i = 1, insize
+          psize = psize + 1
+          q => q%nextSibling
+          if (.not. associated(q)) then
+            exit
+          endif
+        end do
+
+        qsize = insize
+
+        do while (psize > 0 .or. (qsize > 0 .and. associated(q)))
+          if (psize == 0) then
+            e => q
+            q => q%nextSibling
+            qsize = qsize - 1
+
+          else if (qsize == 0 .or. (.not. associated(q))) then
+            e => p;
+            p => p%nextSibling
+            psize = psize - 1
+
+          else if (p%get_micros() >= q%get_micros()) then
+            e => p
+            p => p%nextSibling
+            psize = psize - 1
+
+          else
+            e => q
+            q => q%nextSibling
+            qsize = qsize - 1
+
+          end if
+
+          if (associated(tail)) then
+            tail%nextSibling => e
+          else
+            head => e
+          endif
+          tail => e
+
+        end do
+
+        p => q
+
+      end do
+
+      nullify(tail%nextSibling)
+
+      if (nmerges <= 1) then
+        return
+      endif
+
+      insize = insize * 2
+
+    end do
+  end subroutine
+
+  subroutine timer_sort(self)
+    class(timer_t), intent(inout), target :: self
+    type(node_t), pointer :: node
+
+    call sort_nodes(self%root, node)
+
+    node => self%root
+    do while (associated(node))
+      call node%sort_children()
+      node => node%nextSibling
+    enddo
+  end subroutine
+
+  recursive subroutine node_sort_children(self)
+    class(node_t), intent(inout) :: self
+    type(node_t), pointer :: node
+
+    call sort_nodes(self%firstChild, self%lastChild)
+
+    node => self%firstChild
+    do while (associated(node))
+      call node%sort_children()
+      node => node%nextSibling
+    enddo
+  end subroutine
+
 end module

test/test_timings.F90

@@ -5,17 +5,28 @@ program test_timings
 !make ENABLE=EXPORT_DYNAMIC
 !make DISABLE=OPENMP
   use ftimings
-  use, intrinsic :: iso_c_binding,  only : C_DOUBLE
+  use, intrinsic :: iso_c_binding,  only : C_DOUBLE, C_INT
   implicit none
   type(timer_t) :: timer
   integer, parameter :: rk = C_DOUBLE
-  integer :: i, j
+  integer :: i, j, dummy
+
+  interface
+    function sleep(seconds) bind(C, name="sleep")
+      import C_INT
+      integer(C_INT) :: sleep
+      integer(C_INT), intent(in), value :: seconds
+    end function
+  end interface
 
   call timer%enable()
+  call timer%start("pre-program")
+  dummy = sleep(1)
+  call timer%stop("pre-program")
   call timer%start("program")
-  do i = 1,100
+  do i = 1,20
     ! Test a bit more complex enable/disable decisions
-    if (i < 5 .or. mod(i,10) == 0) then
+    if (i < 5 .or. mod(i,4) == 0) then
       call timer%enable()
     else
       call timer%disable()
@@ -32,19 +43,19 @@ program test_timings
     call timer%stop("cycle")
 
     if (timer%is_enabled()) then
-      if (i == 90) then
+