/* MPI implementation of GNU Fortran Coarray Library Copyright (C) 2011 Free Software Foundation, Inc. Contributed by Tobias Burnus This file is part of the GNU Fortran Coarray Runtime Library (libcaf). Libcaf is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 3, or (at your option) any later version. Libcaf is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. Under Section 7 of GPL version 3, you are granted additional permissions described in the GCC Runtime Library Exception, version 3.1, as published by the Free Software Foundation. You should have received a copy of the GNU General Public License and a copy of the GCC Runtime Library Exception along with this program; see the files COPYING3 and COPYING.RUNTIME respectively. If not, see . */ #include "libcaf.h" #include #include #include /* For memcpy. */ #include /* For variadic arguments. */ #include /* Define GFC_CAF_CHECK to enable run-time checking. */ /* #define GFC_CAF_CHECK 1 */ static void error_stop (int error) __attribute__ ((noreturn)); /* Global variables. */ static int caf_mpi_initialized; static int caf_this_image; static int caf_num_images; static int caf_is_finalized; caf_static_t *caf_static_list = NULL; /* Keep in sync with single.c. */ static void caf_runtime_error (const char *message, ...) { va_list ap; fprintf (stderr, "Fortran runtime error on image %d: ", caf_this_image); va_start (ap, message); vfprintf (stderr, message, ap); va_end (ap); fprintf (stderr, "\n"); /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */ /* FIXME: Do some more effort than just MPI_ABORT. */ MPI_Abort (MPI_COMM_WORLD, EXIT_FAILURE); /* Should be unreachable, but to make sure also call exit. */ exit (EXIT_FAILURE); } /* Initialize coarray program. This routine assumes that no other MPI initialization happened before; otherwise MPI_Initialized had to be used. As the MPI library might modify the command-line arguments, the routine should be called before the run-time libaray is initialized. */ void _gfortran_caf_init (int *argc, char ***argv, int *this_image, int *num_images) { if (caf_num_images == 0) { /* caf_mpi_initialized is only true if the main program is not written in Fortran. */ MPI_Initialized (&caf_mpi_initialized); if (!caf_mpi_initialized) MPI_Init (argc, argv); MPI_Comm_size (MPI_COMM_WORLD, &caf_num_images); MPI_Comm_rank (MPI_COMM_WORLD, &caf_this_image); caf_this_image++; } if (this_image) *this_image = caf_this_image; if (num_images) *num_images = caf_num_images; } /* Finalize coarray program. */ void _gfortran_caf_finalize (void) { while (caf_static_list != NULL) { caf_static_t *tmp = caf_static_list->prev; free (caf_static_list->token[caf_this_image-1]); free (caf_static_list->token); free (caf_static_list); caf_static_list = tmp; } if (!caf_mpi_initialized) MPI_Finalize (); caf_is_finalized = 1; } void * _gfortran_caf_register (ptrdiff_t size, caf_register_t type, void **token, int *stat, char *errmsg, int errmsg_len) { void *local; int err; if (unlikely (caf_is_finalized)) goto error; /* Start MPI if not already started. */ if (caf_num_images == 0) _gfortran_caf_init (NULL, NULL, NULL, NULL); /* Token contains only a list of pointers. */ local = malloc (size); token = malloc (sizeof (void*) * caf_num_images); if (unlikely (local == NULL || token == NULL)) goto error; /* token[img-1] is the address of the token in image "img". */ err = MPI_Allgather (&local, sizeof (void*), MPI_BYTE, token, sizeof (void*), MPI_BYTE, MPI_COMM_WORLD); if (unlikely (err)) { free (local); free (token); goto error; } if (type == CAF_REGTYPE_COARRAY_STATIC) { caf_static_t *tmp = malloc (sizeof (caf_static_t)); tmp->prev = caf_static_list; tmp->token = token; caf_static_list = tmp; } if (stat) *stat = 0; return local; error: { char *msg; if (caf_is_finalized) msg = "Failed to allocate coarray - there are stopped images"; else msg = "Failed to allocate coarray"; if (stat) { *stat = caf_is_finalized ? STAT_STOPPED_IMAGE : 1; if (errmsg_len > 0) { int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len : (int) strlen (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); } } else caf_runtime_error (msg); } return NULL; } void _gfortran_caf_deregister (void **token, int *stat, char *errmsg, int errmsg_len) { if (unlikely (caf_is_finalized)) { const char msg[] = "Failed to deallocate coarray - " "there are stopped images"; if (stat) { *stat = STAT_STOPPED_IMAGE; if (errmsg_len > 0) { int len = ((int) sizeof (msg) - 1 > errmsg_len) ? errmsg_len : (int) sizeof (msg) - 1; memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); } return; } caf_runtime_error (msg); } _gfortran_caf_sync_all (NULL, NULL, 0); if (stat) *stat = 0; free (token[caf_this_image-1]); free (token); } void _gfortran_caf_sync_all (int *stat, char *errmsg, int errmsg_len) { int ierr; if (unlikely (caf_is_finalized)) ierr = STAT_STOPPED_IMAGE; else ierr = MPI_Barrier (MPI_COMM_WORLD); if (stat) *stat = ierr; if (ierr) { char *msg; if (caf_is_finalized) msg = "SYNC ALL failed - there are stopped images"; else msg = "SYNC ALL failed"; if (errmsg_len > 0) { int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len : (int) strlen (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); } else caf_runtime_error (msg); } } /* SYNC IMAGES. Note: SYNC IMAGES(*) is passed as count == -1 while SYNC IMAGES([]) has count == 0. Note further that SYNC IMAGES(*) is not equivalent to SYNC ALL. */ void _gfortran_caf_sync_images (int count, int images[], int *stat, char *errmsg, int errmsg_len) { int ierr; if (count == 0 || (count == 1 && images[0] == caf_this_image)) { if (stat) *stat = 0; return; } #ifdef GFC_CAF_CHECK { int i; for (i = 0; i < count; i++) if (images[i] < 1 || images[i] > caf_num_images) { fprintf (stderr, "COARRAY ERROR: Invalid image index %d to SYNC " "IMAGES", images[i]); error_stop (1); } } #endif /* FIXME: SYNC IMAGES with a nontrivial argument cannot easily be mapped to MPI communicators. Thus, exist early with an error message. */ if (count > 0) { fprintf (stderr, "COARRAY ERROR: SYNC IMAGES not yet implemented"); error_stop (1); } /* Handle SYNC IMAGES(*). */ if (unlikely (caf_is_finalized)) ierr = STAT_STOPPED_IMAGE; else ierr = MPI_Barrier (MPI_COMM_WORLD); if (stat) *stat = ierr; if (ierr) { char *msg; if (caf_is_finalized) msg = "SYNC IMAGES failed - there are stopped images"; else msg = "SYNC IMAGES failed"; if (errmsg_len > 0) { int len = ((int) strlen (msg) > errmsg_len) ? errmsg_len : (int) strlen (msg); memcpy (errmsg, msg, len); if (errmsg_len > len) memset (&errmsg[len], ' ', errmsg_len-len); } else caf_runtime_error (msg); } } /* ERROR STOP the other images. */ static void error_stop (int error) { /* FIXME: Shutdown the Fortran RTL to flush the buffer. PR 43849. */ /* FIXME: Do some more effort than just MPI_ABORT. */ MPI_Abort (MPI_COMM_WORLD, error); /* Should be unreachable, but to make sure also call exit. */ exit (error); } /* ERROR STOP function for string arguments. */ void _gfortran_caf_error_stop_str (const char *string, int32_t len) { fputs ("ERROR STOP ", stderr); while (len--) fputc (*(string++), stderr); fputs ("\n", stderr); error_stop (1); } /* ERROR STOP function for numerical arguments. */ void _gfortran_caf_error_stop (int32_t error) { fprintf (stderr, "ERROR STOP %d\n", error); error_stop (error); }