Commit fc4cea7e authored by Lorenz Hüdepohl's avatar Lorenz Hüdepohl
Browse files

Initial working version

parent 612533f3
*.la
*.lo
*.o
.deps
.dirstamp
.libs
Makefile
Makefile.in
aclocal.m4
ar-lib
autom4te.cache/
compile
config.guess
config.h
config.h.in
config.h.in~
config.log
config.status
config.sub
configure
depcomp
install-sh
libtool
ltmain.sh
m4/
missing
stamp-h1
ftimings-*.pc
ftimings_test
ftimings.mod
AUTOMAKE_OPTIONS = subdir-objects
ACLOCAL_AMFLAGS = ${ACLOCAL_FLAGS} -I m4
AM_CFLAGS = -DPACKAGE_FILESDIR=\"$(filesdir)\" \
-O2 --pedantic-error -ansi -Wall --std=gnu99 \
$(GSL_CFLAGS) $(CFLAG_VISIBILITY)
# libraries
lib_LTLIBRARIES = libftimings-@FTIMINGS_API_VERSION@.la
# libftimings
libftimings_@FTIMINGS_API_VERSION@_la_SOURCES = \
ftimings/time.c \
ftimings/ftimings.f90
libftimings_@FTIMINGS_API_VERSION@_la_LDFLAGS = -version-info $(FTIMINGS_SO_VERSION)
ftimings_includedir = $(includedir)/ftimings-$(FTIMINGS_API_VERSION)
nobase_ftimings_include_HEADERS = ftimings.mod
ftimings_libincludedir = $(libdir)/ftimings-$(FTIMINGS_API_VERSION)/include
pkgconfigdir = $(libdir)/pkgconfig
pkgconfig_DATA = ftimings-$(FTIMINGS_API_VERSION).pc
# programs
bin_PROGRAMS = ftimings_test
# test
ftimings_test_SOURCES = test/test_timings.F90
ftimings_test_LDADD = libftimings-@FTIMINGS_API_VERSION@.la
#!/bin/sh -e
mkdir -p m4/
test -n "$srcdir" || srcdir=`dirname "$0"`
test -n "$srcdir" || srcdir=.
autoreconf --force --install --verbose "$srcdir"
AC_INIT([libftimings], [0.1])
AC_PREREQ([2.59])
AC_CONFIG_MACRO_DIR([m4])
AC_CONFIG_HEADERS([config.h])
AM_INIT_AUTOMAKE([foreign -Wall -Werror])
m4_ifdef([AM_PROG_AR], [AM_PROG_AR])
AM_PROG_CC_C_O
AC_PROG_FC
AC_FC_LIBRARY_LDFLAGS
AC_FC_FREEFORM
LT_INIT
PKG_PROG_PKG_CONFIG
AC_SUBST([FTIMINGS_SO_VERSION], [0:1:0])
AC_SUBST([FTIMINGS_API_VERSION], [0.1])
AC_CONFIG_FILES([Makefile
ftimings-${FTIMINGS_API_VERSION}.pc:ftimings.pc.in
])
AC_OUTPUT
prefix=@prefix@
exec_prefix=@exec_prefix@
libdir=@libdir@
includedir=@includedir@
Name: @PACKAGE_NAME@
Description: FTIMINGS
Version: @PACKAGE_VERSION@
URL: @PACKAGE_URL@
Libs: -L${libdir} -lftimings-@FTIMINGS_API_VERSION@
fcflags= -I${includedir}/ftimings-@FTIMINGS_API_VERSION@
module ftimings
use, intrinsic :: iso_c_binding, only : C_INT64_T, C_DOUBLE
implicit none
save
public
integer, parameter, private :: name_length = 32
integer, parameter, private :: rk = C_DOUBLE
interface
function microseconds_since_epoch() result(ms) bind(C, name="microseconds_since_epoch")
use, intrinsic :: iso_c_binding
implicit none
integer(kind=C_INT64_T) :: ms
end function
end interface
type node_t
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
contains
procedure, pass :: new_child => node_new_child
procedure, pass :: get_child => node_get_child
procedure, pass :: print_graph => node_print_graph
procedure, pass :: sum_of_children => node_sum_of_children
procedure, pass :: sum_of_children_with_name => node_sum_of_children_with_name
end type
type timer_t
logical :: active = .false.
type(node_t), pointer :: root
type(node_t), pointer :: current_node
contains
procedure, pass :: start => timer_start
procedure, pass :: stop => timer_stop
procedure, pass :: free => timer_free
procedure, pass :: print => timer_print
procedure, pass :: enable => timer_enable
procedure, pass :: disable => timer_disable
procedure, pass :: is_enabled => timer_is_enabled
procedure, pass :: in_entries => timer_in_entries
procedure, pass :: get => timer_get
procedure, pass :: since => timer_since
end type
type(timer_t) :: timer
character(len=name_length), parameter :: own = "(own)"
contains
function node_new_child(self, name) result(new)
class(node_t), intent(inout), target :: self
character(len=*), intent(in) :: name
type(node_t), pointer :: new
if (.not. associated(self%lastChild)) then
allocate(self%lastChild)
new => self%lastChild
self%firstChild => new
else
allocate(self%lastChild%nextSibling)
new => self%lastChild%nextSibling
self%lastChild => new
endif
new%name = name
new%micros = 0
new%count = 0
select type (self)
type is (node_t)
new%parent => self
class default
stop "node_new_child(): This should not happen"
end select
nullify(new%firstChild)
nullify(new%lastChild)
nullify(new%nextSibling)
end function
function string_eq(str1, str2) result(eq)
character(len=name_length), intent(in) :: str1
character(len=*), intent(in) :: str2
logical :: eq
eq = trim(str1) .eq. str2(1:min(len(trim(str2)), name_length))
end function
function node_get_child(self, name) result(child)
class(node_t), intent(in) :: self
character(len=*), intent(in) :: name
type(node_t), pointer :: child
child => self%firstChild
do while (associated(child))
if (string_eq(child%name, name)) then
return
endif
child => child%nextSibling
enddo
nullify(child)
end function
recursive subroutine deallocate_node(entry)
type(node_t), intent(inout), pointer :: entry
type(node_t), pointer :: nextSibling
if (associated(entry%firstChild)) then
call deallocate_node(entry%firstChild)
endif
nextSibling => entry%nextSibling
deallocate(entry)
nullify(entry)
if (associated(nextSibling)) then
call deallocate_node(nextSibling)
endif
end subroutine
function node_sum_of_children(self) result(sum_time)
class(node_t), intent(in) :: self
type(node_t), pointer :: cur_entry
integer(kind=C_INT64_T) :: sum_time, child_time
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
cur_entry => cur_entry%nextSibling
enddo
end function
recursive function node_sum_of_children_with_name(self, name) result(sum_time)
class(node_t), intent(in) :: self
character(len=*), intent(in) :: name
type(node_t), pointer :: cur_entry
integer(kind=C_INT64_T) :: sum_time
sum_time = 0
cur_entry => self%firstChild
do while (associated(cur_entry))
if (string_eq(cur_entry%name, name)) then
sum_time = sum_time + cur_entry%micros
else
sum_time = sum_time + cur_entry%sum_of_children_with_name(name)
endif
cur_entry => cur_entry%nextSibling
enddo
end function
recursive subroutine node_print_graph(self, indent_level)
class(node_t), intent(in) :: self
integer, intent(in) :: indent_level
character(len=64) :: format_spec
character(len=name_length) :: name, suffix
integer :: i
integer(kind=C_INT64_T) :: current_ms
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)
else
current_ms = self%micros
write(format_spec,'("(",i0,"x,""|_ "",a",i0,",2x,f10.6)")') indent_level * 2 + 2, len(self%name)
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)
else
name = self%name
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
endif
if (associated(self%firstChild)) then
call self%firstChild%print_graph(indent_level + 1)
endif
if (associated(self%nextSibling)) then
call self%nextSibling%print_graph(indent_level)
endif
end subroutine
subroutine timer_enable(self)
class(timer_t), intent(inout), target :: self
self%active = .true.
end subroutine
subroutine timer_disable(self)
class(timer_t), intent(inout), target :: self
self%active = .false.
end subroutine
function timer_is_enabled(self) result(is)
class(timer_t), intent(inout), target :: self
logical :: is
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
logical, intent(in), optional :: replace
type(node_t), pointer :: node
!$ integer :: omp_get_thread_num, omp_get_num_threads, omp_get_level, omp_get_ancestor_thread_num
!$ integer :: i
if (.not. self%active) then
return
endif
! Deal with nested parallelization
!$ do i = 0, omp_get_level()
!$ if (omp_get_ancestor_thread_num(i) > 0) then
!$ return
!$ endif
!$ end do
!$omp master
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
endif
endif
node%micros = node%micros - microseconds_since_epoch()
node%count = node%count + 1
endif
self%current_node => node
!$omp end master
end subroutine
subroutine timer_stop(self, name)
class(timer_t), intent(inout), target :: self
character(len=*), intent(in) :: name
logical :: error
!$ integer :: omp_get_level, omp_get_ancestor_thread_num
!$ integer :: i
if (.not. self%active) then
return
endif
! Deal with nested parallelization
!$ do i = 0, omp_get_level()
!$ if (omp_get_ancestor_thread_num(i) > 0) then
!$ return
!$ endif
!$ end do
!$omp master
error = .false.
if (.not. associated(self%current_node)) then
write(0,'(a)') "Called %stop(""" // trim(name) // """) without first calling %start(""" // trim(name) // &
& """), disabling timings"
call self%free()
self%active = .false.
error = .true.
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)"
call self%free()
self%active = .false.
error = .true.
endif
if (.not. error) then
! take the time
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)
endif
endif
!$omp end master
end subroutine
subroutine timer_free(self)
class(timer_t), intent(inout), target :: self
if (associated(self%root)) then
call deallocate_node(self%root)
endif
nullify(self%root)
nullify(self%current_node)
end subroutine
subroutine timer_print(self, name1, name2, name3, name4)
class(timer_t), intent(in), target :: self
character(len=*), intent(in), optional :: name1, name2, name3, name4
type(node_t), pointer :: node
if (.not. self%active) then
return
endif
node => self%root
if (present(name1)) then
node => node%get_child(name1)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name1) // """"
return
endif
end if
if (present(name2)) then
node => node%get_child(name2)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name2) // """"
return
endif
end if
if (present(name3)) then
node => node%get_child(name3)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name3) // """"
return
endif
end if
if (present(name4)) then
node => node%get_child(name4)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name4) // """"
return
endif
end if
call node%print_graph(0)
end subroutine
!> Return the sum of all entries with a certain name below
!> a given node. Specify the name with the last argument, the
!> path to the starting point with the first few parameters
!>
!> \param name1, .., namei-1 The path to the starting node
!> \param namei The name of all sub-entries below this
!> node to which are summed together
!>
!> For example timer%in_entries("foo", "bar", "parallel") returns
!> the sum of all entries named "parallel" below the foo->bar node
function timer_in_entries(self, name1, name2, name3, name4) result(s)
class(timer_t), intent(in), target :: self
character(len=*), intent(in) :: name1
character(len=*), intent(in), optional :: name2, name3, name4
real(kind=rk) :: s
type(node_t), pointer :: node ! the starting node
character(len=name_length) :: name ! the name of the sections
s = 0._rk
if (.not. self%active) then
return
endif
node => self%root
name = name1
if (present(name2)) then
node => node%get_child(name1)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name1) // """"
return
endif
name = name2
end if
if (present(name3)) then
node => node%get_child(name2)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name2) // """"
return
endif
name = name3
end if
if (present(name4)) then
node => node%get_child(name3)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name3) // """"
return
endif
name = name4
end if
s = real(node%sum_of_children_with_name(name), kind=rk) / 1e6_rk
end function
function timer_get(self, name1, name2, name3, name4) result(s)
class(timer_t), intent(in), target :: self
character(len=*), intent(in), optional :: name1, name2, name3, name4
real(kind=rk) :: s
type(node_t), pointer :: node
s = 0._rk
if (.not. self%active) then
return
endif
node => self%root
if (present(name1)) then
node => node%get_child(name1)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name1) // """"
return
endif
end if
if (present(name2)) then
node => node%get_child(name2)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name2) // """"
return
endif
end if
if (present(name3)) then
node => node%get_child(name3)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name3) // """"
return
endif
end if
if (present(name4)) then
node => node%get_child(name4)
if (.not. associated(node)) then
write(0,'(a)') "Could not descend to """ // trim(name4) // """"
return
endif
end if