Commit ec142266 authored by Thomas Jahns's avatar Thomas Jahns 🤸
Browse files

Add capability to change abort handler from Fortran.

parent 7548a602
......@@ -69,7 +69,9 @@ static void
PPM_set_default_comm_f(MPI_Fint *comm_f)
{
#if defined(USE_MPI) && defined(HAVE_MPI_COMM_F2C)
MPI_Comm comm_c = MPI_Comm_f2c(*comm_f);
int flag = 0;
MPI_Comm comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
MPI_Comm_f2c(*comm_f):PPM_default_comm;
#else
MPI_Comm comm_c = *comm_f;
#endif
......@@ -129,6 +131,80 @@ PPM_abort_default(MPI_Comm *comm, const char *msg, const char *source, int line)
PPM_abort_func PPM_abort = PPM_abort_default;
void
PPM_restore_default_abort_handler()
{
PPM_abort = PPM_abort_default;
}
FCALLSCSUB0(PPM_restore_default_abort_handler, PPM_RESTORE_DEFAULT_ABORT_HNDL,
ppm_restore_default_abort_hndl)
static void
abort_ppm_handler_wrapper(MPI_Comm *comm, const char msg[],
const char source[], int line);
static void
set_abort_ppm_handler_f(void *abort_ppm_handler);
FCALLSCSUB1(set_abort_ppm_handler_f, PPM_SET_ABORT_HANDLER,
ppm_set_abort_handler, ROUTINE)
static void
PPM_abort_default_f(MPI_Fint *comm_f, const char *msg, const char *source,
int line)
{
#if defined(USE_MPI) && defined(HAVE_MPI_COMM_F2C)
int flag = 0;
MPI_Comm comm_c = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
MPI_Comm_f2c(*comm_f):PPM_default_comm;
#else
MPI_Comm comm_c = *comm_f;
#endif
PPM_abort_default(&comm_c, msg, source, line);
}
FCALLSCSUB4(PPM_abort_default_f,PPM_ABORT_DEFAULT,ppm_abort_default,
PVOID,STRING,STRING,INT)
/* this must be the last piece of code in the file because we
* redefine a cfortran.h internal here, to allow calls to Fortran
* function pointers */
#undef CFC_
#define CFC_(UN,LN) (UN)
#undef CFextern
#define CFextern static
PROTOCCALLSFSUB4(*abort_ppm_fortran_fp,,PVOID,STRING,STRING,INT)
static void
set_abort_ppm_handler_f(void *abort_ppm_handler)
{
abort_ppm_fortran_fp = abort_ppm_handler;
PPM_abort = abort_ppm_handler_wrapper;
}
static void
abort_ppm_handler_wrapper(MPI_Comm *comm, const char msg[],
const char source[], int line)
{
#if defined(USE_MPI) && defined(HAVE_MPI_COMM_F2C)
int flag = 0;
MPI_Fint comm_f = (MPI_Initialized(&flag) == MPI_SUCCESS && flag)?
MPI_Comm_c2f(*comm):(MPI_Fint)0;
#else
MPI_Fint comm_f = *comm;
#endif
/* cfortran.h does not understand const char * */
char *msg_arg = (char *)msg, *source_arg = (char *)source;
#undef CPPPROTOCLSFSUB14
#define CPPPROTOCLSFSUB14(UN,LN,T1,T2,T3,T4,T5,T6,T7,T8,T9,TA,TB,TC,TD,TE)
CCALLSFSUB4(*abort_ppm_fortran_fp,,PVOID,STRING,STRING,INT,
&comm_f, msg_arg, source_arg, line);
}
/*
* Local Variables:
* license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
......
......@@ -59,7 +59,7 @@ MODULE ppm_base
INTEGER :: comm
END SUBROUTINE ppm_set_default_comm
!> abort operation in library, this subroutine will call the
!> function reference assigned to PPM_abort on the C side directly.
!! function reference assigned to PPM_abort on the C side directly.
!!
!! @param comm communicator to use in PPM_abort call, defaults
!! to ppm_default_comm if not given
......@@ -70,9 +70,23 @@ MODULE ppm_base
INTEGER, INTENT(in) :: comm, line
CHARACTER(*), INTENT(in) :: msg, source
END SUBROUTINE ppm_abort
SUBROUTINE ppm_set_abort_handler(f)
INTERFACE
SUBROUTINE f(comm, msg, source, line)
INTEGER, INTENT(in) :: comm, line
CHARACTER(len=*) :: msg, source
END SUBROUTINE f
END INTERFACE
END SUBROUTINE ppm_set_abort_handler
SUBROUTINE ppm_restore_default_abort_hndl
END SUBROUTINE ppm_restore_default_abort_hndl
END INTERFACE
PUBLIC :: ppm_default_comm, set_default_comm
PUBLIC :: abort_ppm, assertion
PUBLIC :: set_abort_handler, restore_default_abort_handler
CONTAINS
!> abort operation in library, this will call the function reference
!! assigned to PPM_abort on the C side and substitute non-provided
......@@ -106,6 +120,21 @@ CONTAINS
CALL ppm_set_default_comm(comm)
END SUBROUTINE set_default_comm
!> set routine f to use as abort function which is called on ppm_abort
SUBROUTINE set_abort_handler(f)
INTERFACE
SUBROUTINE f(comm, msg, source, line)
INTEGER, INTENT(in) :: comm, line
CHARACTER(len=*) :: msg, source
END SUBROUTINE f
END INTERFACE
CALL ppm_set_abort_handler(f)
END SUBROUTINE set_abort_handler
SUBROUTINE restore_default_abort_handler
CALL ppm_restore_default_abort_hndl
END SUBROUTINE restore_default_abort_handler
!> check invariant and call abort_ppm if false
!!
!! @param cond invariant to test
......
......@@ -38,6 +38,7 @@ noinst_PROGRAMS = test_qsort test_uniform_partition test_irand \
test_combinatorics test_compact_mask_index \
test_graph_csr test_ieee_emulation \
test_ddp_math \
test_abort_ppm \
test_set_partition test_set_repartition
if USE_MPI
......@@ -79,6 +80,8 @@ test_set_repartition_SOURCES = test_set_repartition.f90
test_set_repartition_mp_SOURCES = test_set_repartition_mp.f90
test_abort_ppm_SOURCES = test_abort_ppm.f90
EXTRA_DIST=test_strided_extents.f90 test_set_repartition_mp.f90
./$(DEPDIR)/FC.deps: $(SOURCES) Makefile
......
! test_abort_ppm.f90 --- test functions to exchange abort handler from
! Fortran
!
! Copyright (C) 2011 Thomas Jahns <jahns@dkrz.de>
!
! Version: 1.0
! Author: Thomas Jahns <jahns@dkrz.de>
! Maintainer: Thomas Jahns <jahns@dkrz.de>
! URL: https://www.dkrz.de/redmine/projects/show/scales-ppm
!
! Redistribution and use in source and binary forms, with or without
! modification, are permitted provided that the following conditions are
! met:
!
! Redistributions of source code must retain the above copyright notice,
! this list of conditions and the following disclaimer.
!
! Redistributions in binary form must reproduce the above copyright
! notice, this list of conditions and the following disclaimer in the
! documentation and/or other materials provided with the distribution.
!
! Neither the name of the DKRZ GmbH nor the names of its contributors
! may be used to endorse or promote products derived from this software
! without specific prior written permission.
!
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
! IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
! TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
! PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
! OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
! EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
! PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
! LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
! NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
! SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
!
MODULE test_abort_ppm_static_data
IMPLICIT NONE
PRIVATE
INTEGER, SAVE :: testi = 0
CHARACTER(len=255), SAVE :: testc="foo"
PUBLIC :: testi, testc
END MODULE test_abort_ppm_static_data
PROGRAM test_abort_ppm
USE ppm_base, ONLY: ppm_default_comm, abort_ppm, set_abort_handler, &
restore_default_abort_handler, assertion
USE test_abort_ppm_static_data, ONLY: testi, testc
IMPLICIT NONE
EXTERNAL :: my_handler
CALL assertion(testi == 0 .AND. testc == 'foo', &
__FILE__, &
__LINE__, &
'initial values mangled')
CALL set_abort_handler(my_handler)
CALL abort_ppm("bar", "baz", 42)
CALL assertion(testi == 42 .AND. testc == 'baz', &
__FILE__, &
__LINE__, &
'value copy incomplete')
CALL restore_default_abort_handler
END PROGRAM test_abort_ppm
SUBROUTINE my_handler(comm, msg, source, line)
USE test_abort_ppm_static_data, ONLY: testi, testc
INTEGER, INTENT(in) :: comm, line
CHARACTER(len=*) :: msg, source
testi = line
testc = msg
END SUBROUTINE my_handler
!
! Local Variables:
! license-project-url: "https://www.dkrz.de/redmine/projects/show/scales-ppm"
! license-default: "bsd"
! End:
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment