diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 31c986a46..d520270b9 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -296,6 +296,11 @@ jobs: ./run-fpm.sh run --verbose --example stop_with_no_code ( set +e ; ./run-fpm.sh run --verbose --example stop_with_integer_code ; test $? = 99 ) ( set +e ; ./run-fpm.sh run --verbose --example error_stop_with_integer_code ; test $? = 100 ) + ( set +e ; \ + export CAF_IMAGES=1; \ + ./run-fpm.sh run --verbose --example fail_image 2>&1 | tee output ; \ + test ${PIPESTATUS[0]} > 0 && grep -q "FAIL IMAGE" output \ + ) unset GASNET_SPAWN_VERBOSE for ((i=1; i<=4; i++)); do \ (set +e ; \ diff --git a/docs/implementation-status.md b/docs/implementation-status.md index 15e378ed2..9550d974e 100644 --- a/docs/implementation-status.md +++ b/docs/implementation-status.md @@ -42,7 +42,7 @@ are accepted, but in some cases, the associated runtime behavior is not fully im |-----------|--------|-------| | `prif_init` | **YES** | | | `prif_stop`, `prif_error_stop` | **YES** | | -| `prif_fail_image` | no | | +| `prif_fail_image` | **YES** | trivial implementation | | `prif_register_stop_callback` | **YES** | | diff --git a/example/support-test/fail_image.F90 b/example/support-test/fail_image.F90 new file mode 100644 index 000000000..bbfc516a5 --- /dev/null +++ b/example/support-test/fail_image.F90 @@ -0,0 +1,15 @@ +program fail_image + use iso_c_binding, only: c_bool + use prif, only : & + prif_init & + ,prif_error_stop & + ,prif_fail_image + implicit none + + integer init_exit_code + logical(kind=c_bool), parameter :: false = .false._c_bool + + call prif_init(init_exit_code) + call prif_fail_image() + call prif_error_stop(quiet=false) ! test fails if this line runs +end program diff --git a/src/caffeine/caffeine.c b/src/caffeine/caffeine.c index b4704a252..43ea6b7fb 100644 --- a/src/caffeine/caffeine.c +++ b/src/caffeine/caffeine.c @@ -137,6 +137,18 @@ void caf_decaffeinate(int exit_code) gasnet_exit(exit_code); } +void caf_fail_image() { + fprintf(stderr,"FAIL IMAGE on image %d\n", myproc+1); + gasnett_flush_streams(); + + if (numprocs > 1) { + // spin-wait until we are killed, while still servicing network requests: + GASNET_BLOCKUNTIL((gasnett_nsleep(1000), 0)); + } + + gasnet_exit(1); +} + void caf_fatal_error( const CFI_cdesc_t* Fstr ) { const char *msg = (char *)Fstr->base_addr; diff --git a/src/caffeine/prif_private_s.F90 b/src/caffeine/prif_private_s.F90 index 62c352238..77c275ea7 100644 --- a/src/caffeine/prif_private_s.F90 +++ b/src/caffeine/prif_private_s.F90 @@ -53,6 +53,11 @@ subroutine caf_decaffeinate(exit_code) bind(C) integer(c_int), value :: exit_code end subroutine + subroutine caf_fail_image() bind(C) + !! void caf_fail_image(); + implicit none + end subroutine + pure subroutine caf_fatal_error(str) bind(C) !! void caf_fatal_error( const CFI_cdesc_t* Fstr ) import c_char diff --git a/src/caffeine/program_termination_s.F90 b/src/caffeine/program_termination_s.F90 index 883c2535f..860ad9394 100644 --- a/src/caffeine/program_termination_s.F90 +++ b/src/caffeine/program_termination_s.F90 @@ -135,7 +135,11 @@ subroutine prif_error_stop_integer(quiet, stop_code) end subroutine module procedure prif_fail_image - call unimplemented("prif_fail_image") +# ifndef CAF_FAIL_IMAGE_SUPPRESS_FLUSH + call flush_all() +# endif + + call caf_fail_image() end procedure subroutine run_callbacks(is_error_stop, quiet, stop_code_int, stop_code_char)