WSJT-X/lib/iso_c_utilities.f90
Bill Somerville f416a52def Make Fortran profiling timer function a callback with a default null implementation
Groundwork for calling the decoders directly from C/C++ threads.

To  access   the  timer   module  timer_module   must  now   be  used.
Instrumented code need  only use the module function  'timer' which is
now a  procedure pointer that  is guaranteed to be  associated (unless
null()  is assigned  to it,  which should  not be  done). The  default
behaviour of 'timer' is to do nothing.

If a  Fortran program  wishes to  profile code it  should now  use the
timer_impl module  which contains a default  timer implementation. The
main program should call 'init_timer([filename])' before using 'timer'
or     calling     routines     that     are     instrumented.      If
'init_timer([filename])'.  If it is called  then an optional file name
may  be  provided  with  'timer.out'  being used  as  a  default.  The
procedure 'fini_timer()' may be called to close the file.

The default  timer implementation is  thread safe if used  with OpenMP
multi-threaded code  so long as  the OpenMP  thread team is  given the
copyin(/timer_private/) attribute  for correct operation.   The common
block /timer_private/ should  be included for OpenMP  use by including
the file 'timer_common.inc'.

The module 'lib/timer_C_wrapper.f90' provides  a Fortran wrapper along
with 'init' and 'fini' subroutines  which allow a C/C++ application to
call timer instrumented  Fortran code and for it  to receive callbacks
of 'timer()' subroutine invocations.  No C/C++ timer implementation is
provided at this stage.

git-svn-id: svn+ssh://svn.code.sf.net/p/wsjt/wsjt/branches/wsjtx@6320 ab8295b8-cf94-4d9e-aec4-7959e3be5d79
2015-12-27 15:40:57 +00:00

88 lines
3.0 KiB
Fortran

module iso_c_utilities
use, intrinsic :: iso_c_binding, only: c_ptr, c_char, c_f_pointer, c_associated
implicit none
public :: c_to_f_string, c_f_dyn_string
private
character(c_char), dimension(1), save, target :: dummy_string = "?"
interface ! strlen is a standard C function from <string.h>
! int strlen(char *string)
function strlen (string) result (len) bind (c, name="strlen")
use, intrinsic :: iso_c_binding, only: c_ptr, c_size_t
implicit none
type(c_ptr), value :: string
integer(kind=c_size_t) :: len
end function strlen
! void free(void * p)
subroutine c_free (p) bind (c, name="free")
use, intrinsic :: iso_c_binding, only: c_ptr
implicit none
type(c_ptr), value :: p
end subroutine c_free
end interface
contains
!
! Cast C string pointer to Fortran string pointer
!
! Warning! - C data must outlive result scope
!
function c_to_f_string (c_str) result (f_str)
use, intrinsic :: iso_c_binding, only: c_ptr, c_f_pointer, c_char
implicit none
type(c_ptr), intent(in) :: c_str
character(kind=c_char, len=:), pointer :: f_str
character(kind=c_char), pointer :: arr(:)
interface ! strlen is a standard C function from <string.h>
! int strlen(char *string)
function strlen (string) result (len) bind (c, name="strlen")
use, intrinsic :: iso_c_binding, only: c_ptr, c_size_t
implicit none
type(c_ptr), value :: string
integer(kind=c_size_t) :: len
end function strlen
end interface
call c_f_pointer (c_str, arr, [strlen (c_str)])
call get_scalar_pointer (size (arr), arr, f_str)
end function c_to_f_string
subroutine get_scalar_pointer (scalar_len, scalar, fptr)
! Convert a null-terminated C string into a Fortran character pointer
use, intrinsic :: iso_c_binding, only: c_char
integer, intent(in) :: scalar_len
character(kind=c_char, len=scalar_len), intent(in), target :: scalar(1)
character(kind=c_char, len=:), pointer :: fptr
fptr => scalar(1)
end subroutine get_scalar_pointer
function c_f_dyn_string (cptr) result (fstr)
! Convert a null-terminated malloc'ed C string into a Fortran character array
type(c_ptr), intent(in) :: cptr ! The C address
character(kind=c_char), allocatable :: fstr(:)
character(kind=c_char), pointer :: fptr(:)
interface ! strlen is a standard C function from <string.h>
! void free(void * p)
subroutine c_free (p) bind (c, name="free")
use, intrinsic :: iso_c_binding, only: c_ptr
implicit none
type(c_ptr), value :: p
end subroutine c_free
end interface
if (c_associated (cptr)) then
call c_f_pointer (fptr=fptr, cptr=cptr, shape=[strlen(cptr)])
else
! To avoid segfaults, associate FPTR with a dummy target:
fptr => dummy_string
end if
fstr = fptr
call c_free (cptr)
end function c_f_dyn_string
end module